summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-02-02 16:12:00 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-02-02 16:12:00 (GMT)
commitce9bf924511484c14218bd13b2abf5cfc9967c25 (patch)
tree5d833ae8b02170afdeff4568db0b0c3b4041b30d /generic
parent10c9ce76f08286c1d9c1a229c633bf12576c25c5 (diff)
downloadtcl-ce9bf924511484c14218bd13b2abf5cfc9967c25.zip
tcl-ce9bf924511484c14218bd13b2abf5cfc9967c25.tar.gz
tcl-ce9bf924511484c14218bd13b2abf5cfc9967c25.tar.bz2
Turned the [array] command into a true ensemble. Test changes indicate some
alteration to error messages, otherwise no change.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclVar.c1728
3 files changed, 1184 insertions, 560 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 2612aef..08414c8 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.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: tclBasic.c,v 1.439 2010/01/30 16:33:25 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.440 2010/02/02 16:12:00 dkf Exp $
*/
#include "tclInt.h"
@@ -194,7 +194,6 @@ static const CmdInfo builtInCmds[] = {
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1},
- {"array", Tcl_ArrayObjCmd, NULL, NULL, 1},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1},
#ifndef EXCLUDE_OBSOLETE_COMMANDS
{"case", Tcl_CaseObjCmd, NULL, NULL, 1},
@@ -750,11 +749,12 @@ Tcl_CreateInterp(void)
}
/*
- * Create the "binary", "chan", "dict", "info" and "string" ensembles.
- * Note that all these commands (and their subcommands that are not
- * present in the global namespace) are wholly safe.
+ * Create the "array", "binary", "chan", "dict", "info" and "string"
+ * ensembles. Note that all these commands (and their subcommands that are
+ * not present in the global namespace) are wholly safe.
*/
+ TclInitArrayCmd(interp);
TclInitBinaryCmd(interp);
TclInitChanCmd(interp);
TclInitDictCmd(interp);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 97a5e44..64f6544 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.456 2010/01/30 16:33:25 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.457 2010/02/02 16:12:00 dkf Exp $
*/
#ifndef _TCLINT
@@ -3015,9 +3015,7 @@ MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_ArrayObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
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"