diff options
Diffstat (limited to 'generic/tclVar.c')
| -rw-r--r-- | generic/tclVar.c | 1728 |
1 files changed, 1177 insertions, 551 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c index 6b2f623..d97eb27 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.188 2010/02/02 00:29:32 dkf Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.189 2010/02/02 16:12:00 dkf Exp $ */ #include "tclInt.h" @@ -2765,57 +2765,301 @@ Tcl_LappendObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_ArrayObjCmd -- + * TclArraySet -- * - * This object-based function is invoked to process the "array" Tcl - * command. See the user documentation for details on what it does. + * Set the elements of an array. If there are no elements to set, create + * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the + * TclSetupEnv routine. * * Results: * A standard Tcl result object. * * Side effects: - * See the user documentation. + * A variable will be created if one does not already exist. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_ArrayObjCmd( - ClientData dummy, /* Not used. */ +TclArraySet( Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *arrayNameObj, /* The array name. */ + Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is + * NULL, create an empty array. */ { + Var *varPtr, *arrayPtr; + int result, i; + + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, + /*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; + } + /* - * The list of constants below should match the arrayOptions string array - * below. + * Install the contents of the dictionary or list into the array. */ - enum { - ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, - ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, - ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET - }; - static const char *const arrayOptions[] = { - "anymore", "donesearch", "exists", "get", "names", "nextelement", - "set", "size", "startsearch", "statistics", "unset", NULL - }; + if (arrayElemObj->typePtr == &tclDictType) { + Tcl_Obj *keyPtr, *valuePtr; + Tcl_DictSearch search; + int done; + + if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { + return TCL_ERROR; + } + if (done == 0) { + /* + * Empty, so we'll just force the array to be properly existing + * instead. + */ + + goto ensureArray; + } + + /* + * Don't need to look at result of Tcl_DictObjFirst as we've just + * successfully used a dictionary operation on the same object. + */ + + for (Tcl_DictObjFirst(interp, arrayElemObj, &search, + &keyPtr, &valuePtr, &done) ; !done ; + 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. + */ + + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, + keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + return TCL_OK; + } else { + /* + * Not a dictionary, so assume (and convert to, for backward- + * -compatability reasons) a list. + */ + + int elemLen; + Tcl_Obj **elemPtrs, *copyListObj; + + result = TclListObjGetElements(interp, arrayElemObj, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (elemLen & 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list must have an even number of elements", -1)); + return TCL_ERROR; + } + if (elemLen == 0) { + goto ensureArray; + } + + /* + * We needn't worry about traces invalidating arrayPtr: should that be + * the case, TclPtrSetVar will return NULL so that we break out of the + * loop and return an error. + */ + + copyListObj = TclListObjCopy(NULL, arrayElemObj); + for (i=0 ; i<elemLen ; i+=2) { + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, + elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ + result = TCL_ERROR; + break; + } + } + Tcl_DecrRefCount(copyListObj); + return result; + } + + /* + * The list is empty make sure we have an array, or create one if + * necessary. + */ + + ensureArray: + if (varPtr != NULL) { + if (TclIsVarArray(varPtr)) { + /* + * Already an array, done. + */ + + return TCL_OK; + } + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", + needArray, -1); + return TCL_ERROR; + } + } + TclSetVarArray(varPtr); + varPtr->value.tablePtr = (TclVarHashTable *) + ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayStartSearchCmd -- + * + * This object-based function is invoked to process the "array + * startsearch" Tcl command. See the user documentation for details on + * what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static int +ArrayStartSearchCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNamePtr; - int notArray; - int index, result; + int isNew; + ArraySearch *searchPtr; + const char *varName; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", - 0, &index) != TCL_OK) { + /* + * Locate the array variable + */ + + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + varName = TclGetString(varNamePtr); + + /* + * 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, varNamePtr, 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_AppendResult(interp, "\"", varName, "\" isn't an array", NULL); + return TCL_ERROR; + } + + /* + * Make a new array search with a free name. + */ + + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, (char *) varPtr, &isNew); + if (isNew) { + 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 = ((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 = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); + Tcl_SetHashValue(hPtr, searchPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayAnyMoreCmd -- + * + * This object-based function is invoked to process the "array anymore" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayAnyMoreCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; + int gotValue; + ArraySearch *searchPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } @@ -2823,7 +3067,7 @@ Tcl_ArrayObjCmd( * Locate the array variable */ - varNamePtr = objv[2]; + varNamePtr = objv[1]; varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); @@ -2847,680 +3091,1062 @@ Tcl_ArrayObjCmd( * traces. */ - notArray = 0; if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - notArray = 1; + Tcl_AppendResult(interp, "\"", TclGetString(varNamePtr), + "\" isn't an array", NULL); + return TCL_ERROR; } - switch (index) { - case ARRAY_ANYMORE: { - ArraySearch *searchPtr; + /* + * Get the search. + */ - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); - if (searchPtr == NULL) { - return TCL_ERROR; - } - while (1) { - Var *varPtr2; + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[2]); + if (searchPtr == NULL) { + return TCL_ERROR; + } - if (searchPtr->nextEntry != NULL) { - varPtr2 = VarHashGetValue(searchPtr->nextEntry); - if (!TclIsVarUndefined(varPtr2)) { - break; - } - } - searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); - if (searchPtr->nextEntry == NULL) { - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[0]); - return TCL_OK; + /* + * Scan forward to find if there are any further elements in the array + * that are defined. + */ + + while (1) { + if (searchPtr->nextEntry != NULL) { + varPtr = VarHashGetValue(searchPtr->nextEntry); + if (!TclIsVarUndefined(varPtr)) { + gotValue = 1; + break; } } - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[1]); - break; + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + gotValue = 0; + break; + } } - case ARRAY_DONESEARCH: { - ArraySearch *searchPtr, *prevPtr; + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[gotValue]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayNextElementCmd -- + * + * This object-based function is invoked to process the "array + * nextelement" Tcl command. See the user documentation for details on + * what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); - return TCL_ERROR; - } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); - if (searchPtr == NULL) { + /* ARGSUSED */ +static int +ArrayNextElementCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; + ArraySearch *searchPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); + return TCL_ERROR; + } + + /* + * Locate the array variable + */ + + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, 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, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { return TCL_ERROR; } - 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); + } + + /* + * 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_AppendResult(interp, "\"", TclGetString(varNamePtr), + "\" isn't an array", NULL); + return TCL_ERROR; + } + + /* + * Get the search. + */ + + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[2]); + if (searchPtr == NULL) { + 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. + */ + + while (1) { + Tcl_HashEntry *hPtr = searchPtr->nextEntry; + + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; } } else { - for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } + searchPtr->nextEntry = NULL; + } + varPtr = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr)) { + Tcl_SetObjResult(interp, VarHashGetKey(varPtr)); + return TCL_OK; } - ckfree((char *) searchPtr); - break; } - case ARRAY_NEXTELEMENT: { - ArraySearch *searchPtr; - Tcl_HashEntry *hPtr; - Var *varPtr2; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayDoneSearchCmd -- + * + * This object-based function is invoked to process the "array + * donesearch" Tcl command. See the user documentation for details on + * what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayDoneSearchCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj *varNamePtr; + ArraySearch *searchPtr, *prevPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); + return TCL_ERROR; + } + + /* + * Locate the array variable + */ - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, 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, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { return TCL_ERROR; } - if (notArray) { - goto error; - } - searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); - if (searchPtr == NULL) { - 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_AppendResult(interp, "\"", TclGetString(varNamePtr), + "\" isn't an array", NULL); + return TCL_ERROR; + } + + /* + * Get the search. + */ + + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[2]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + + /* + * Unhook the search from the list of searches associated with the + * variable. + */ + + 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); } - while (1) { - hPtr = searchPtr->nextEntry; - if (hPtr == NULL) { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - return TCL_OK; - } - } else { - searchPtr->nextEntry = NULL; - } - varPtr2 = VarHashGetValue(hPtr); - if (!TclIsVarUndefined(varPtr2)) { + } else { + for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; break; } } - Tcl_SetObjResult(interp, VarHashGetKey(varPtr2)); - break; } - case ARRAY_STARTSEARCH: { - ArraySearch *searchPtr; - int isNew; - const char *varName = TclGetString(varNamePtr); + ckfree((char *) searchPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayExistsCmd -- + * + * This object-based function is invoked to process the "array exists" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayExistsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + int notArray; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); + return TCL_ERROR; + } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + /* + * 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 (notArray) { - goto error; - } - searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); - hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, - (char *) varPtr, &isNew); - if (isNew) { - 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 = ((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 = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); - Tcl_SetHashValue(hPtr, searchPtr); - break; + /* + * Check whether we've actually got an array variable. + */ + + notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)); + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayGetCmd -- + * + * This object-based function is invoked to process the "array get" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayGetCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr, *varPtr2; + Tcl_Obj *varNamePtr, *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr; + Tcl_Obj **namePtrPtr; + Tcl_HashSearch search; + const char *pattern; + int i, count, result; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?"); + return TCL_ERROR; } - case ARRAY_EXISTS: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + /* + * Locate the array variable + */ + + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, 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, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { return TCL_ERROR; } - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); - break; - case ARRAY_GET: { - Tcl_HashSearch search; - Var *varPtr2; - const char *pattern = NULL; - const char *name; - Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; - int i, count; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); - 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; + } + + pattern = (objc == 3 ? TclGetString(objv[2]) : NULL); + + /* + * Store the array names in a new object. + */ + + TclNewObj(nameLstPtr); + Tcl_IncrRefCount(nameLstPtr); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); + if (varPtr2 == NULL) { + goto searchDone; } - if (notArray) { - return TCL_OK; + if (TclIsVarUndefined(varPtr2)) { + goto searchDone; } - if (objc == 4) { - pattern = TclGetString(objv[3]); + result = Tcl_ListObjAppendElement(interp, nameLstPtr, + VarHashGetKey(varPtr2)); + if (result != TCL_OK) { + TclDecrRefCount(nameLstPtr); + return result; } + goto searchDone; + } - /* - * Store the array names in a new object. - */ - - TclNewObj(nameLstPtr); - Tcl_IncrRefCount(nameLstPtr); - if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); - if (varPtr2 == NULL) { - goto searchDone; - } - if (TclIsVarUndefined(varPtr2)) { - goto searchDone; - } - result = Tcl_ListObjAppendElement(interp, nameLstPtr, - VarHashGetKey(varPtr2)); - if (result != TCL_OK) { - TclDecrRefCount(nameLstPtr); - return result; - } - goto searchDone; + for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2; varPtr2 = VarHashNextVar(&search)) { + if (TclIsVarUndefined(varPtr2)) { + continue; + } + namePtr = VarHashGetKey(varPtr2); + if (pattern && !Tcl_StringMatch(TclGetString(namePtr), pattern)) { + continue; /* Element name doesn't match pattern. */ } - for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2; varPtr2 = VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { - continue; - } - namePtr = VarHashGetKey(varPtr2); - name = TclGetString(namePtr); - if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { - continue; /* Element name doesn't match pattern. */ - } - result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); - if (result != TCL_OK) { - TclDecrRefCount(nameLstPtr); - return result; - } + result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); + if (result != TCL_OK) { + TclDecrRefCount(nameLstPtr); + return result; } + } - searchDone: - /* - * Make sure the Var structure of the array is not removed by a trace - * while we're working. - */ + /* + * Make sure the Var structure of the array is not removed by a trace + * while we're working. + */ - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)++; - } + searchDone: + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } - /* - * Get the array values corresponding to each element name. - */ + /* + * Get the array values corresponding to each element name. + */ - TclNewObj(tmpResPtr); - result = Tcl_ListObjGetElements(interp, nameLstPtr, &count, - &namePtrPtr); - if (result != TCL_OK) { - goto errorInArrayGet; - } + TclNewObj(tmpResPtr); + result = Tcl_ListObjGetElements(interp, nameLstPtr, &count, &namePtrPtr); + if (result != TCL_OK) { + goto errorInArrayGet; + } - for (i=0 ; i<count ; i++) { - namePtr = *namePtrPtr++; - valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, - TCL_LEAVE_ERR_MSG); - if (valuePtr == NULL) { + for (i=0 ; i<count ; i++) { + namePtr = *namePtrPtr++; + valuePtr = Tcl_ObjGetVar2(interp, varNamePtr, namePtr, + TCL_LEAVE_ERR_MSG); + if (valuePtr == NULL) { + /* + * Some trace played a trick on us; we need to diagnose to adapt + * our behaviour: was the array element unset, or did the + * modification modify the complete array? + */ + + if (TclIsVarArray(varPtr)) { /* - * Some trace played a trick on us; we need to diagnose to - * adapt our behaviour: was the array element unset, or did - * the modification modify the complete array? + * The array itself looks OK, the variable was undefined: + * forget it. */ - if (TclIsVarArray(varPtr)) { - /* - * The array itself looks OK, the variable was undefined: - * forget it. - */ - - continue; - } else { - result = TCL_ERROR; - goto errorInArrayGet; - } - } - result = Tcl_DictObjPut(interp, tmpResPtr, namePtr, valuePtr); - if (result != TCL_OK) { - goto errorInArrayGet; + continue; } + result = TCL_ERROR; + goto errorInArrayGet; } - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)--; + result = Tcl_DictObjPut(interp, tmpResPtr, namePtr, valuePtr); + if (result != TCL_OK) { + goto errorInArrayGet; } - Tcl_SetObjResult(interp, tmpResPtr); - TclDecrRefCount(nameLstPtr); - break; + } + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + Tcl_SetObjResult(interp, tmpResPtr); + TclDecrRefCount(nameLstPtr); + return TCL_OK; - errorInArrayGet: - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)--; + errorInArrayGet: + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + TclDecrRefCount(nameLstPtr); + TclDecrRefCount(tmpResPtr); /* Free unneeded temp result. */ + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayNamesCmd -- + * + * This object-based function is invoked to process the "array names" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayNamesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *const options[] = { + "-exact", "-glob", "-regexp", NULL + }; + enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr, *varPtr2; + Tcl_Obj *varNamePtr, *namePtr, *resultPtr, *patternPtr; + Tcl_HashSearch search; + const char *pattern; + int mode = OPT_GLOB; + + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); + return TCL_ERROR; + } + + /* + * Locate the array variable + */ + + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, 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, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + return TCL_ERROR; } - TclDecrRefCount(nameLstPtr); - TclDecrRefCount(tmpResPtr); /* Free unneeded temp result. */ - return result; } - case ARRAY_NAMES: { - Tcl_HashSearch search; - Var *varPtr2; - const char *pattern; - const char *name; - Tcl_Obj *namePtr, *resultPtr, *patternPtr; - int mode, matched = 0; - static const char *const options[] = { - "-exact", "-glob", "-regexp", NULL - }; - enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; - - mode = OPT_GLOB; - - if ((objc < 3) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2,objv, "arrayName ?mode? ?pattern?"); + + /* + * 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; + } + + /* + * Finish parsing the arguments. + */ + + if (objc == 3) { + patternPtr = objv[2]; + pattern = TclGetString(patternPtr); + } else if (objc == 4) { + patternPtr = objv[3]; + pattern = TclGetString(patternPtr); + if (Tcl_GetIndexFromObj(interp, objv[2], options, "option", 0, + &mode) != TCL_OK) { return TCL_ERROR; } - if (notArray) { - return TCL_OK; + } else { + patternPtr = NULL; + pattern = NULL; + } + + /* + * Check for the trivial cases where we can use a direct lookup. + */ + + TclNewObj(resultPtr); + if ((mode==OPT_GLOB && pattern && TclMatchIsTrivial(pattern)) + || (mode==OPT_EXACT)) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternPtr); + if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) { + /* + * This can't fail; lappending to an empty object always works. + */ + + Tcl_ListObjAppendElement(NULL, resultPtr, VarHashGetKey(varPtr2)); } - if (objc == 4) { - patternPtr = objv[3]; - pattern = TclGetString(patternPtr); - } else if (objc == 5) { - patternPtr = objv[4]; - pattern = TclGetString(patternPtr); - if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", 0, - &mode) != TCL_OK) { - return TCL_ERROR; - } - } else { - patternPtr = NULL; - pattern = NULL; - } - TclNewObj(resultPtr); - if (((enum options) mode)==OPT_GLOB && pattern!=NULL && - TclMatchIsTrivial(pattern)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternPtr); - if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) { - result = Tcl_ListObjAppendElement(interp, resultPtr, - VarHashGetKey(varPtr2)); - if (result != TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + 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; + } + namePtr = VarHashGetKey(varPtr2); + if (patternPtr) { + const char *name = TclGetString(namePtr); + int matched; + + 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_RegExpMatch(interp, name, pattern); + if (matched < 0) { TclDecrRefCount(resultPtr); - return result; + return TCL_ERROR; } + break; } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; - } - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { + if (matched == 0) { continue; } - namePtr = VarHashGetKey(varPtr2); - name = TclGetString(namePtr); - if (objc > 3) { - switch ((enum options) mode) { - case OPT_EXACT: - matched = (strcmp(name, pattern) == 0); - break; - case OPT_GLOB: - matched = Tcl_StringMatch(name, pattern); - break; - case OPT_REGEXP: - matched = Tcl_RegExpMatch(interp, name, pattern); - if (matched < 0) { - TclDecrRefCount(resultPtr); - return TCL_ERROR; - } - break; - } - if (matched == 0) { - continue; - } - } - - result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); - if (result != TCL_OK) { - TclDecrRefCount(namePtr); /* Free unneeded name obj. */ - return result; - } } - Tcl_SetObjResult(interp, resultPtr); - break; + + Tcl_ListObjAppendElement(NULL, resultPtr, namePtr); } - case ARRAY_SET: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); - return TCL_ERROR; - } - return TclArraySet(interp, objv[2], objv[3]); - case ARRAY_UNSET: - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); - return TCL_ERROR; - } - if (notArray) { - return TCL_OK; - } - if (objc == 3) { - /* - * When no pattern is given, just unset the whole array. - */ + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArraySetCmd -- + * + * This object-based function is invoked to process the "array set" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - return TclObjUnsetVar2(interp, varNamePtr, NULL, 0); - } else { - Tcl_HashSearch search; - Var *varPtr2, *protectedVarPtr; - const char *pattern = TclGetString(objv[3]); + /* ARGSUSED */ +static int +ArraySetCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; - /* - * With a trivial pattern, we can just unset. - */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); + return TCL_ERROR; + } - if (TclMatchIsTrivial(pattern)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); - if (varPtr2 != NULL && !TclIsVarUndefined(varPtr2)) { - return TclPtrUnsetVar(interp, varPtr2, varPtr, varNamePtr, - objv[3], 0, -1); - } - return TCL_OK; - } + /* + * Locate the array variable + */ - /* - * Non-trivial case (well, deeply tricky really). We peek inside - * the hash iterator in order to allow us to guarantee that the - * following element in the array will not be scrubbed until we - * have dealt with it. This stops the overall iterator from ending - * up pointing into deallocated memory. [Bug 2939073] - */ + varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - protectedVarPtr = NULL; - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - /* - * Drop the extra ref immediately. We don't need to free it at - * this point though; we'll be unsetting it if necessary soon. - */ + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ - if (varPtr2 == protectedVarPtr) { - VarHashRefCount(varPtr2)--; - } + 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; + } + } - /* - * Guard the next item in the search chain by incrementing its - * refcount. This guarantees that the hash table iterator - * won't be dangling on the next time through the loop. - */ + return TclArraySet(interp, objv[1], objv[2]); +} + +/* + *---------------------------------------------------------------------- + * + * ArraySizeCmd -- + * + * This object-based function is invoked to process the "array size" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - if (search.nextEntryPtr != NULL) { - protectedVarPtr = VarHashGetValue(search.nextEntryPtr); - VarHashRefCount(protectedVarPtr)++; - } else { - protectedVarPtr = NULL; - } + /* ARGSUSED */ +static int +ArraySizeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; + Tcl_HashSearch search; + Var *varPtr2; + int size = 0; - if (!TclIsVarUndefined(varPtr2)) { - Tcl_Obj *namePtr = VarHashGetKey(varPtr2); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); + return TCL_ERROR; + } - if (Tcl_StringMatch(TclGetString(namePtr), pattern) - && TclPtrUnsetVar(interp, varPtr2, varPtr, - varNamePtr, namePtr, 0, -1) != TCL_OK) { - /* - * If we incremented a refcount, we must decrement it - * here as we will not be coming back properly due to - * the error. - */ + /* + * Locate the array variable + */ - if (protectedVarPtr) { - VarHashRefCount(protectedVarPtr)--; - } - return TCL_ERROR; - } - } - } - break; - } + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - case ARRAY_SIZE: { - Tcl_HashSearch search; - Var *varPtr2; - int size; + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { return TCL_ERROR; } - size = 0; + } + + /* + * 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. */ - if (!notArray) { - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { - continue; - } + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { + if (!TclIsVarUndefined(varPtr2)) { size++; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); - break; } - case ARRAY_STATISTICS: { - char *stats; + Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayStatsCmd -- + * + * This object-based function is invoked to process the "array + * statistics" Tcl command. See the user documentation for details on + * what it does. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - if (notArray) { - goto error; - } + /* ARGSUSED */ +static int +ArrayStatsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; + char *stats; - stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); - if (stats != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); - ckfree((char *)stats); - } else { - Tcl_SetResult(interp,"error reading array statistics",TCL_STATIC); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); + return TCL_ERROR; + } + + /* + * Locate the array variable + */ + + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, 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, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { return TCL_ERROR; } - break; } + + /* + * 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_AppendResult(interp, "\"", TclGetString(varNamePtr), + "\" isn't an array", NULL); + return TCL_ERROR; } - return TCL_OK; - error: - Tcl_AppendResult(interp, "\"", TclGetString(varNamePtr), - "\" isn't an array", NULL); - return TCL_ERROR; + stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); + if (stats == NULL) { + Tcl_SetResult(interp, "error reading array statistics", TCL_STATIC); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); + ckfree(stats); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclArraySet -- + * ArrayUnsetCmd -- * - * Set the elements of an array. If there are no elements to set, create - * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the - * TclSetupEnv routine. + * This object-based function is invoked to process the "array unset" Tcl + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result object. * * Side effects: - * A variable will be created if one does not already exist. + * See the user documentation. * *---------------------------------------------------------------------- */ -int -TclArraySet( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *arrayNameObj, /* The array name. */ - Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is - * NULL, create an empty array. */ + /* ARGSUSED */ +static int +ArrayUnsetCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) { + Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; - int result, i; + Tcl_Obj *varNamePtr; + Tcl_HashSearch search; + Var *varPtr2, *protectedVarPtr; + const char *pattern; - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, - /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return TCL_ERROR; - } - if (arrayPtr) { - CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?pattern?"); return TCL_ERROR; } - if (arrayElemObj == NULL) { - goto ensureArray; - } - /* - * Install the contents of the dictionary or list into the array. + * Locate the array variable */ - if (arrayElemObj->typePtr == &tclDictType) { - Tcl_Obj *keyPtr, *valuePtr; - Tcl_DictSearch search; - int done; + varNamePtr = objv[1]; + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { + /* + * 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, varNamePtr, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { return TCL_ERROR; } - if (done == 0) { - /* - * Empty, so we'll just force the array to be properly existing - * instead. - */ + } - goto ensureArray; - } + /* + * 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; + } + if (objc == 2) { /* - * Don't need to look at result of Tcl_DictObjFirst as we've just - * successfully used a dictionary operation on the same object. + * When no pattern is given, just unset the whole array. */ - for (Tcl_DictObjFirst(interp, arrayElemObj, &search, - &keyPtr, &valuePtr, &done) ; !done ; - 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. - */ + return TclObjUnsetVar2(interp, varNamePtr, NULL, 0); + } - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + /* + * With a trivial pattern, we can just unset. + */ - if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, - keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { - Tcl_DictObjDone(&search); - return TCL_ERROR; - } + pattern = TclGetString(objv[2]); + if (TclMatchIsTrivial(pattern)) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[2]); + if (!varPtr2 || TclIsVarUndefined(varPtr2)) { + return TCL_OK; } - return TCL_OK; - } else { + return TclPtrUnsetVar(interp, varPtr2, varPtr, varNamePtr, objv[2], 0, + -1); + } + + /* + * Non-trivial case (well, deeply tricky really). We peek inside the hash + * iterator in order to allow us to guarantee that the following element + * in the array will not be scrubbed until we have dealt with it. This + * stops the overall iterator from ending up pointing into deallocated + * memory. [Bug 2939073] + */ + + protectedVarPtr = NULL; + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { /* - * Not a dictionary, so assume (and convert to, for backward- - * -compatability reasons) a list. + * Drop the extra ref immediately. We don't need to free it at this + * point though; we'll be unsetting it if necessary soon. */ - int elemLen; - Tcl_Obj **elemPtrs, *copyListObj; - - result = TclListObjGetElements(interp, arrayElemObj, - &elemLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (elemLen & 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list must have an even number of elements", -1)); - return TCL_ERROR; - } - if (elemLen == 0) { - goto ensureArray; + if (varPtr2 == protectedVarPtr) { + if (VarHashRefCount(varPtr2)-- == 1) { + CleanupVar(varPtr2, varPtr); + } } /* - * We needn't worry about traces invalidating arrayPtr: should that be - * the case, TclPtrSetVar will return NULL so that we break out of the - * loop and return an error. + * Guard the next item in the search chain by incrementing its + * refcount. This guarantees that the hash table iterator won't be + * dangling on the next time through the loop. */ - copyListObj = TclListObjCopy(NULL, arrayElemObj); - for (i=0 ; i<elemLen ; i+=2) { - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); - - if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, - elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ - result = TCL_ERROR; - break; - } + if (search.nextEntryPtr != NULL) { + protectedVarPtr = VarHashGetValue(search.nextEntryPtr); + VarHashRefCount(protectedVarPtr)++; + } else { + protectedVarPtr = NULL; } - Tcl_DecrRefCount(copyListObj); - return result; - } - - /* - * The list is empty make sure we have an array, or create one if - * necessary. - */ - ensureArray: - if (varPtr != NULL) { - if (TclIsVarArray(varPtr)) { - /* - * Already an array, done. - */ + if (!TclIsVarUndefined(varPtr2)) { + Tcl_Obj *namePtr = VarHashGetKey(varPtr2); - return TCL_OK; - } - if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ + if (Tcl_StringMatch(TclGetString(namePtr), pattern) + && TclPtrUnsetVar(interp, varPtr2, varPtr, varNamePtr, + namePtr, 0, -1) != TCL_OK) { + /* + * If we incremented a refcount, we must decrement it here as + * we will not be coming back properly due to the error. + */ - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", - needArray, -1); - return TCL_ERROR; + if (protectedVarPtr) { + if (VarHashRefCount(protectedVarPtr)-- == 1) { + CleanupVar(protectedVarPtr, varPtr); + } + } + return TCL_ERROR; + } } } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = (TclVarHashTable *) - ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- * + * TclInitArrayCmd -- + * + * This creates the ensemble for the "array" command. + * + * Results: + * The handle for the created ensemble. + * + * Side effects: + * Creates a command in the global namespace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +Tcl_Command +TclInitArrayCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap arrayImplMap[] = { + {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL}, + {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL}, + {"exists", ArrayExistsCmd, NULL, NULL, NULL}, + {"get", ArrayGetCmd, NULL, NULL, NULL}, + {"names", ArrayNamesCmd, NULL, NULL, NULL}, + {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL}, + {"set", ArraySetCmd, NULL, NULL, NULL}, + {"size", ArraySizeCmd, NULL, NULL, NULL}, + {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL}, + {"statistics", ArrayStatsCmd, NULL, NULL, NULL}, + {"unset", ArrayUnsetCmd, NULL, NULL, NULL}, + {NULL, NULL, NULL, NULL, NULL} + }; + + return TclMakeEnsemble(interp, "array", arrayImplMap); +} + +/* + *---------------------------------------------------------------------- + * * ObjMakeUpvar -- * * This function does all of the work of the "global" and "upvar" |