--- /dev/null
+/*
+ * tclDictObj.c --
+ *
+ * This file contains functions that implement the Tcl dict object type
+ * and its accessor command.
+ *
+ * Copyright (c) 2002-2010 by Donal K. Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tommath.h"
+
+/*
+ * Forward declaration.
+ */
+struct Dict;
+
+/*
+ * Prototypes for functions defined later in this file:
+ */
+
+static void DeleteDict(struct Dict *dict);
+static int DictAppendCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictCreateCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictExistsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictGetCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictKeysCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictLappendCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictMergeCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictRemoveCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictReplaceCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictSetCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictSizeCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictUnsetCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictUpdateCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictValuesCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static int DictWithCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const *objv);
+static void DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeDictInternalRep(Tcl_Obj *dictPtr);
+static void InvalidateDictChain(Tcl_Obj *dictObj);
+static int SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfDict(Tcl_Obj *dictPtr);
+static Tcl_HashEntry * AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr);
+static inline void InitChainTable(struct Dict *dict);
+static inline void DeleteChainTable(struct Dict *dict);
+static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict,
+ Tcl_Obj *keyPtr, int *newPtr);
+static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr);
+static Tcl_NRPostProc FinalizeDictUpdate;
+static Tcl_NRPostProc FinalizeDictWith;
+static Tcl_ObjCmdProc DictForNRCmd;
+static Tcl_ObjCmdProc DictMapNRCmd;
+static Tcl_NRPostProc DictForLoopCallback;
+static Tcl_NRPostProc DictMapLoopCallback;
+
+/*
+ * Table of dict subcommand names and implementations.
+ */
+
+static const EnsembleImplMap implementationMap[] = {
+ {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
+ {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
+ {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
+ {"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
+ {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
+ {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
+ {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
+ {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
+ {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
+ {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
+ {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
+ {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
+ {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
+ {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
+ {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
+ {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 },
+ {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 },
+ {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 },
+ {NULL, NULL, NULL, NULL, NULL, 0}
+};
+
+/*
+ * Internal representation of the entries in the hash table that backs a
+ * dictionary.
+ */
+
+typedef struct ChainEntry {
+ Tcl_HashEntry entry;
+ struct ChainEntry *prevPtr;
+ struct ChainEntry *nextPtr;
+} ChainEntry;
+
+/*
+ * Internal representation of a dictionary.
+ *
+ * The internal representation of a dictionary object is a hash table (with
+ * Tcl_Objs for both keys and values), a reference count and epoch number for
+ * detecting concurrent modifications of the dictionary, and a pointer to the
+ * parent object (used when invalidating string reps of pathed dictionary
+ * trees) which is NULL in normal use. The fact that hash tables know (with
+ * appropriate initialisation) already about objects makes key management /so/
+ * much easier!
+ *
+ * Reference counts are used to enable safe iteration across hashes while
+ * allowing the type of the containing object to be modified.
+ */
+
+typedef struct Dict {
+ Tcl_HashTable table; /* Object hash table to store mapping in. */
+ ChainEntry *entryChainHead; /* Linked list of all entries in the
+ * dictionary. Used for doing traversal of the
+ * entries in the order that they are
+ * created. */
+ ChainEntry *entryChainTail; /* Other end of linked list of all entries in
+ * the dictionary. Used for doing traversal of
+ * the entries in the order that they are
+ * created. */
+ int epoch; /* Epoch counter */
+ size_t refCount; /* Reference counter (see above) */
+ Tcl_Obj *chain; /* Linked list used for invalidating the
+ * string representations of updated nested
+ * dictionaries. */
+} Dict;
+
+/*
+ * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this
+ * must be assignable as well as readable.
+ */
+
+#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1)
+
+/*
+ * The structure below defines the dictionary object type by means of
+ * functions that can be invoked by generic object code.
+ */
+
+const Tcl_ObjType tclDictType = {
+ "dict",
+ FreeDictInternalRep, /* freeIntRepProc */
+ DupDictInternalRep, /* dupIntRepProc */
+ UpdateStringOfDict, /* updateStringProc */
+ SetDictFromAny /* setFromAnyProc */
+};
+
+/*
+ * The type of the specially adapted version of the Tcl_Obj*-containing hash
+ * table defined in the tclObj.c code. This version differs in that it
+ * allocates a bit more space in each hash entry in order to hold the pointers
+ * used to keep the hash entries in a linked list.
+ *
+ * Note that this type of hash table is *only* suitable for direct use in
+ * *this* file. Everything else should use the dict iterator API.
+ */
+
+static const Tcl_HashKeyType chainHashType = {
+ TCL_HASH_KEY_TYPE_VERSION,
+ 0,
+ TclHashObjKey,
+ TclCompareObjKeys,
+ AllocChainEntry,
+ TclFreeObjEntry
+};
+
+/*
+ * Structure used in implementation of 'dict map' to hold the state that gets
+ * passed between parts of the implementation.
+ */
+
+typedef struct {
+ Tcl_Obj *keyVarObj; /* The name of the variable that will have
+ * keys assigned to it. */
+ Tcl_Obj *valueVarObj; /* The name of the variable that will have
+ * values assigned to it. */
+ Tcl_DictSearch search; /* The dictionary search structure. */
+ Tcl_Obj *scriptObj; /* The script to evaluate each time through
+ * the loop. */
+ Tcl_Obj *accumulatorObj; /* The dictionary used to accumulate the
+ * results. */
+} DictMapStorage;
+\f
+/***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AllocChainEntry --
+ *
+ * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key, and
+ * which has a bit of extra space afterwards for storing pointers to the
+ * rest of the chain of entries (the extra pointers are left NULL).
+ *
+ * Results:
+ * The return value is a pointer to the created entry.
+ *
+ * Side effects:
+ * Increments the reference count on the object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+AllocChainEntry(
+ Tcl_HashTable *tablePtr,
+ void *keyPtr)
+{
+ Tcl_Obj *objPtr = keyPtr;
+ ChainEntry *cPtr;
+
+ cPtr = ckalloc(sizeof(ChainEntry));
+ cPtr->entry.key.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr);
+ cPtr->entry.clientData = NULL;
+ cPtr->prevPtr = cPtr->nextPtr = NULL;
+
+ return &cPtr->entry;
+}
+\f
+/*
+ * Helper functions that disguise most of the details relating to how the
+ * linked list of hash entries is managed. In particular, these manage the
+ * creation of the table and initializing of the chain, the deletion of the
+ * table and chain, the adding of an entry to the chain, and the removal of an
+ * entry from the chain.
+ */
+
+static inline void
+InitChainTable(
+ Dict *dict)
+{
+ Tcl_InitCustomHashTable(&dict->table, TCL_CUSTOM_PTR_KEYS,
+ &chainHashType);
+ dict->entryChainHead = dict->entryChainTail = NULL;
+}
+
+static inline void
+DeleteChainTable(
+ Dict *dict)
+{
+ ChainEntry *cPtr;
+
+ for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
+ Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
+
+ TclDecrRefCount(valuePtr);
+ }
+ Tcl_DeleteHashTable(&dict->table);
+}
+
+static inline Tcl_HashEntry *
+CreateChainEntry(
+ Dict *dict,
+ Tcl_Obj *keyPtr,
+ int *newPtr)
+{
+ ChainEntry *cPtr = (ChainEntry *)
+ Tcl_CreateHashEntry(&dict->table, keyPtr, newPtr);
+
+ /*
+ * If this is a new entry in the hash table, stitch it into the chain.
+ */
+
+ if (*newPtr) {
+ cPtr->nextPtr = NULL;
+ if (dict->entryChainHead == NULL) {
+ cPtr->prevPtr = NULL;
+ dict->entryChainHead = cPtr;
+ dict->entryChainTail = cPtr;
+ } else {
+ cPtr->prevPtr = dict->entryChainTail;
+ dict->entryChainTail->nextPtr = cPtr;
+ dict->entryChainTail = cPtr;
+ }
+ }
+
+ return &cPtr->entry;
+}
+
+static inline int
+DeleteChainEntry(
+ Dict *dict,
+ Tcl_Obj *keyPtr)
+{
+ ChainEntry *cPtr = (ChainEntry *)
+ Tcl_FindHashEntry(&dict->table, keyPtr);
+
+ if (cPtr == NULL) {
+ return 0;
+ } else {
+ Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
+
+ TclDecrRefCount(valuePtr);
+ }
+
+ /*
+ * Unstitch from the chain.
+ */
+
+ if (cPtr->nextPtr) {
+ cPtr->nextPtr->prevPtr = cPtr->prevPtr;
+ } else {
+ dict->entryChainTail = cPtr->prevPtr;
+ }
+ if (cPtr->prevPtr) {
+ cPtr->prevPtr->nextPtr = cPtr->nextPtr;
+ } else {
+ dict->entryChainHead = cPtr->nextPtr;
+ }
+
+ Tcl_DeleteHashEntry(&cPtr->entry);
+ return 1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupDictInternalRep --
+ *
+ * Initialize the internal representation of a dictionary Tcl_Obj to a
+ * copy of the internal representation of an existing dictionary object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * "srcPtr"s dictionary internal rep pointer should not be NULL and we
+ * assume it is not NULL. We set "copyPtr"s internal rep to a pointer to
+ * a newly allocated dictionary rep that, in turn, points to "srcPtr"s
+ * key and value objects. Those objects are not actually copied but are
+ * shared between "srcPtr" and "copyPtr". The ref count of each key and
+ * value object is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupDictInternalRep(
+ Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr)
+{
+ Dict *oldDict = DICT(srcPtr);
+ Dict *newDict = ckalloc(sizeof(Dict));
+ ChainEntry *cPtr;
+
+ /*
+ * Copy values across from the old hash table.
+ */
+
+ InitChainTable(newDict);
+ for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
+ Tcl_Obj *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
+ Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ int n;
+ Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n);
+
+ /*
+ * Fill in the contents.
+ */
+
+ Tcl_SetHashValue(hPtr, valuePtr);
+ Tcl_IncrRefCount(valuePtr);
+ }
+
+ /*
+ * Initialise other fields.
+ */
+
+ newDict->epoch = 0;
+ newDict->chain = NULL;
+ newDict->refCount = 1;
+
+ /*
+ * Store in the object.
+ */
+
+ DICT(copyPtr) = newDict;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ copyPtr->typePtr = &tclDictType;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeDictInternalRep --
+ *
+ * Deallocate the storage associated with a dictionary object's internal
+ * representation.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Frees the memory holding the dictionary's internal hash table unless
+ * it is locked by an iteration going over it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeDictInternalRep(
+ Tcl_Obj *dictPtr)
+{
+ Dict *dict = DICT(dictPtr);
+
+ if (dict->refCount-- <= 1) {
+ DeleteDict(dict);
+ }
+ dictPtr->typePtr = NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteDict --
+ *
+ * Delete the structure that is used to implement a dictionary's internal
+ * representation. Called when either the dictionary object loses its
+ * internal representation or when the last iteration over the dictionary
+ * completes.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Decrements the reference count of all key and value objects in the
+ * dictionary, which may free them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteDict(
+ Dict *dict)
+{
+ DeleteChainTable(dict);
+ ckfree(dict);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfDict --
+ *
+ * Update the string representation for a dictionary object. Note: This
+ * function does not invalidate an existing old string rep so storage
+ * will be lost if this has not already been done. This code is based on
+ * UpdateStringOfList in tclListObj.c
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to a valid string that results from the
+ * dict-to-string conversion. This string will be empty if the dictionary
+ * has no key/value pairs. The dictionary internal representation should
+ * not be NULL and we assume it is not NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfDict(
+ Tcl_Obj *dictPtr)
+{
+#define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
+ Dict *dict = DICT(dictPtr);
+ ChainEntry *cPtr;
+ Tcl_Obj *keyPtr, *valuePtr;
+ int i, length, bytesNeeded = 0;
+ const char *elem;
+ char *dst;
+
+ /*
+ * This field is the most useful one in the whole hash structure, and it
+ * is not exposed by any API function...
+ */
+
+ int numElems = dict->table.numEntries * 2;
+
+ /* Handle empty list case first, simplifies what follows */
+ if (numElems == 0) {
+ dictPtr->bytes = tclEmptyStringRep;
+ dictPtr->length = 0;
+ return;
+ }
+
+ /*
+ * Pass 1: estimate space, gather flags.
+ */
+
+ if (numElems <= LOCAL_SIZE) {
+ flagPtr = localFlags;
+ } else {
+ flagPtr = ckalloc(numElems);
+ }
+ for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
+ /*
+ * Assume that cPtr is never NULL since we know the number of array
+ * elements already.
+ */
+
+ flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
+ keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
+ elem = TclGetStringFromObj(keyPtr, &length);
+ bytesNeeded += TclScanElement(elem, length, flagPtr+i);
+ if (bytesNeeded < 0) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+
+ flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
+ valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ elem = TclGetStringFromObj(valuePtr, &length);
+ bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
+ if (bytesNeeded < 0) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ }
+ if (bytesNeeded > INT_MAX - numElems + 1) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ bytesNeeded += numElems;
+
+ /*
+ * Pass 2: copy into string rep buffer.
+ */
+
+ dictPtr->length = bytesNeeded - 1;
+ dictPtr->bytes = ckalloc(bytesNeeded);
+ dst = dictPtr->bytes;
+ for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
+ flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
+ keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
+ elem = TclGetStringFromObj(keyPtr, &length);
+ dst += TclConvertElement(elem, length, dst, flagPtr[i]);
+ *dst++ = ' ';
+
+ flagPtr[i+1] |= TCL_DONT_QUOTE_HASH;
+ valuePtr = Tcl_GetHashValue(&cPtr->entry);
+ elem = TclGetStringFromObj(valuePtr, &length);
+ dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
+ *dst++ = ' ';
+ }
+ dictPtr->bytes[dictPtr->length] = '\0';
+
+ if (flagPtr != localFlags) {
+ ckfree(flagPtr);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetDictFromAny --
+ *
+ * Convert a non-dictionary object into a dictionary object. This code is
+ * very closely related to SetListFromAny in tclListObj.c but does not
+ * actually guarantee that a dictionary object will have a string rep (as
+ * conversions from lists are handled with a special case.)
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * If the string can be converted, it loses any old internal
+ * representation that it had and gains a dictionary's internalRep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetDictFromAny(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr)
+{
+ Tcl_HashEntry *hPtr;
+ int isNew;
+ Dict *dict = ckalloc(sizeof(Dict));
+
+ InitChainTable(dict);
+
+ /*
+ * Since lists and dictionaries have very closely-related string
+ * representations (i.e. the same parsing code) we can safely special-case
+ * the conversion from lists to dictionaries.
+ */
+
+ if (objPtr->typePtr == &tclListType) {
+ int objc, i;
+ Tcl_Obj **objv;
+
+ /* Cannot fail, we already know the Tcl_ObjType is "list". */
+ TclListObjGetElements(NULL, objPtr, &objc, &objv);
+ if (objc & 1) {
+ goto missingValue;
+ }
+
+ for (i=0 ; i<objc ; i+=2) {
+
+ /* Store key and value in the hash table we're building. */
+ hPtr = CreateChainEntry(dict, objv[i], &isNew);
+ if (!isNew) {
+ Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
+
+ /*
+ * Not really a well-formed dictionary as there are duplicate
+ * keys, so better get the string rep here so that we can
+ * convert back.
+ */
+
+ (void) Tcl_GetString(objPtr);
+
+ TclDecrRefCount(discardedValue);
+ }
+ Tcl_SetHashValue(hPtr, objv[i+1]);
+ Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
+ }
+ } else {
+ int length;
+ const char *nextElem = TclGetStringFromObj(objPtr, &length);
+ const char *limit = (nextElem + length);
+
+ while (nextElem < limit) {
+ Tcl_Obj *keyPtr, *valuePtr;
+ const char *elemStart;
+ int elemSize, literal;
+
+ if (TclFindDictElement(interp, nextElem, (limit - nextElem),
+ &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
+ goto errorInFindDictElement;
+ }
+ if (elemStart == limit) {
+ break;
+ }
+ if (nextElem == limit) {
+ goto missingValue;
+ }
+
+ if (literal) {
+ TclNewStringObj(keyPtr, elemStart, elemSize);
+ } else {
+ /* Avoid double copy */
+ TclNewObj(keyPtr);
+ keyPtr->bytes = ckalloc((unsigned) elemSize + 1);
+ keyPtr->length = TclCopyAndCollapse(elemSize, elemStart,
+ keyPtr->bytes);
+ }
+
+ if (TclFindDictElement(interp, nextElem, (limit - nextElem),
+ &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
+ TclDecrRefCount(keyPtr);
+ goto errorInFindDictElement;
+ }
+
+ if (literal) {
+ TclNewStringObj(valuePtr, elemStart, elemSize);
+ } else {
+ /* Avoid double copy */
+ TclNewObj(valuePtr);
+ valuePtr->bytes = ckalloc((unsigned) elemSize + 1);
+ valuePtr->length = TclCopyAndCollapse(elemSize, elemStart,
+ valuePtr->bytes);
+ }
+
+ /* Store key and value in the hash table we're building. */
+ hPtr = CreateChainEntry(dict, keyPtr, &isNew);
+ if (!isNew) {
+ Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
+
+ TclDecrRefCount(keyPtr);
+ TclDecrRefCount(discardedValue);
+ }
+ Tcl_SetHashValue(hPtr, valuePtr);
+ Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
+ }
+ }
+
+ /*
+ * Free the old internalRep before setting the new one. We do this as late
+ * as possible to allow the conversion code, in particular
+ * Tcl_GetStringFromObj, to use that old internalRep.
+ */
+
+ TclFreeIntRep(objPtr);
+ dict->epoch = 0;
+ dict->chain = NULL;
+ dict->refCount = 1;
+ DICT(objPtr) = dict;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclDictType;
+ return TCL_OK;
+
+ missingValue:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "missing value to go with key", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
+ }
+ errorInFindDictElement:
+ DeleteChainTable(dict);
+ ckfree(dict);
+ return TCL_ERROR;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclTraceDictPath --
+ *
+ * Trace through a tree of dictionaries using the array of keys given. If
+ * the flags argument has the DICT_PATH_UPDATE flag is set, a
+ * backward-pointing chain of dictionaries is also built (in the Dict's
+ * chain field) and the chained dictionaries are made into unshared
+ * dictionaries (if they aren't already.)
+ *
+ * Results:
+ * The object at the end of the path, or NULL if there was an error. Note
+ * that this it is an error for an intermediate dictionary on the path to
+ * not exist. If the flags argument has the DICT_PATH_EXISTS set, a
+ * non-existent path gives a DICT_PATH_NON_EXISTENT result.
+ *
+ * Side effects:
+ * If the flags argument is zero or DICT_PATH_EXISTS, there are no side
+ * effects (other than potential conversion of objects to dictionaries.)
+ * If the flags argument is DICT_PATH_UPDATE, the following additional
+ * side effects occur. Shared dictionaries along the path are converted
+ * into unshared objects, and a backward-pointing chain is built using
+ * the chain fields of the dictionaries (for easy invalidation of string
+ * representations using InvalidateDictChain). If the flags argument has
+ * the DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit),
+ * non-existant keys will be inserted with a value of an empty
+ * dictionary, resulting in the path being built.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclTraceDictPath(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ int keyc,
+ Tcl_Obj *const keyv[],
+ int flags)
+{
+ Dict *dict, *newDict;
+ int i;
+
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
+ }
+ dict = DICT(dictPtr);
+ if (flags & DICT_PATH_UPDATE) {
+ dict->chain = NULL;
+ }
+
+ for (i=0 ; i<keyc ; i++) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]);
+ Tcl_Obj *tmpObj;
+
+ if (hPtr == NULL) {
+ int isNew; /* Dummy */
+
+ if (flags & DICT_PATH_EXISTS) {
+ return DICT_PATH_NON_EXISTENT;
+ }
+ if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(keyv[i])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(keyv[i]), NULL);
+ }
+ return NULL;
+ }
+
+ /*
+ * The next line should always set isNew to 1.
+ */
+
+ hPtr = CreateChainEntry(dict, keyv[i], &isNew);
+ tmpObj = Tcl_NewDictObj();
+ Tcl_IncrRefCount(tmpObj);
+ Tcl_SetHashValue(hPtr, tmpObj);
+ } else {
+ tmpObj = Tcl_GetHashValue(hPtr);
+ if (tmpObj->typePtr != &tclDictType
+ && SetDictFromAny(interp, tmpObj) != TCL_OK) {
+ return NULL;
+ }
+ }
+
+ newDict = DICT(tmpObj);
+ if (flags & DICT_PATH_UPDATE) {
+ if (Tcl_IsShared(tmpObj)) {
+ TclDecrRefCount(tmpObj);
+ tmpObj = Tcl_DuplicateObj(tmpObj);
+ Tcl_IncrRefCount(tmpObj);
+ Tcl_SetHashValue(hPtr, tmpObj);
+ dict->epoch++;
+ newDict = DICT(tmpObj);
+ }
+
+ newDict->chain = dictPtr;
+ }
+ dict = newDict;
+ dictPtr = tmpObj;
+ }
+ return dictPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * InvalidateDictChain --
+ *
+ * Go through a dictionary chain (built by an updating invokation of
+ * TclTraceDictPath) and invalidate the string representations of all the
+ * dictionaries on the chain.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * String reps are invalidated and epoch counters (for detecting illegal
+ * concurrent modifications) are updated through the chain of updated
+ * dictionaries.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+InvalidateDictChain(
+ Tcl_Obj *dictObj)
+{
+ Dict *dict = DICT(dictObj);
+
+ do {
+ TclInvalidateStringRep(dictObj);
+ dict->epoch++;
+ dictObj = dict->chain;
+ if (dictObj == NULL) {
+ break;
+ }
+ dict->chain = NULL;
+ dict = DICT(dictObj);
+ } while (dict != NULL);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjPut --
+ *
+ * Add a key,value pair to a dictionary, or update the value for a key if
+ * that key already has a mapping in the dictionary.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * The object pointed to by dictPtr is converted to a dictionary if it is
+ * not already one, and any string representation that it has is
+ * invalidated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DictObjPut(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ Tcl_Obj *keyPtr,
+ Tcl_Obj *valuePtr)
+{
+ Dict *dict;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (Tcl_IsShared(dictPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
+ }
+
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
+ }
+ dict = DICT(dictPtr);
+ hPtr = CreateChainEntry(dict, keyPtr, &isNew);
+ Tcl_IncrRefCount(valuePtr);
+ if (!isNew) {
+ Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
+
+ TclDecrRefCount(oldValuePtr);
+ }
+ Tcl_SetHashValue(hPtr, valuePtr);
+ dict->epoch++;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjGet --
+ *
+ * Given a key, get its value from the dictionary (or NULL if key is not
+ * found in dictionary.)
+ *
+ * Results:
+ * A standard Tcl result. The variable pointed to by valuePtrPtr is
+ * updated with the value for the key. Note that it is not an error for
+ * the key to have no mapping in the dictionary.
+ *
+ * Side effects:
+ * The object pointed to by dictPtr is converted to a dictionary if it is
+ * not already one.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DictObjGet(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ Tcl_Obj *keyPtr,
+ Tcl_Obj **valuePtrPtr)
+{
+ Dict *dict;
+ Tcl_HashEntry *hPtr;
+
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ *valuePtrPtr = NULL;
+ return TCL_ERROR;
+ }
+
+ dict = DICT(dictPtr);
+ hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
+ if (hPtr == NULL) {
+ *valuePtrPtr = NULL;
+ } else {
+ *valuePtrPtr = Tcl_GetHashValue(hPtr);
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjRemove --
+ *
+ * Remove the key,value pair with the given key from the dictionary; the
+ * key does not need to be present in the dictionary.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * The object pointed to by dictPtr is converted to a dictionary if it is
+ * not already one, and any string representation that it has is
+ * invalidated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DictObjRemove(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ Tcl_Obj *keyPtr)
+{
+ Dict *dict;
+
+ if (Tcl_IsShared(dictPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
+ }
+
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ dict = DICT(dictPtr);
+ if (DeleteChainEntry(dict, keyPtr)) {
+ if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
+ }
+ dict->epoch++;
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjSize --
+ *
+ * How many key,value pairs are there in the dictionary?
+ *
+ * Results:
+ * A standard Tcl result. Updates the variable pointed to by sizePtr with
+ * the number of key,value pairs in the dictionary.
+ *
+ * Side effects:
+ * The dictPtr object is converted to a dictionary type if it is not a
+ * dictionary already.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DictObjSize(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ int *sizePtr)
+{
+ Dict *dict;
+
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ dict = DICT(dictPtr);
+ *sizePtr = dict->table.numEntries;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjFirst --
+ *
+ * Start a traversal of the dictionary. Caller must supply the search
+ * context, pointers for returning key and value, and a pointer to allow
+ * indication of whether the dictionary has been traversed (i.e. the
+ * dictionary is empty). The order of traversal is undefined.
+ *
+ * Results:
+ * A standard Tcl result. Updates the variables pointed to by keyPtrPtr,
+ * valuePtrPtr and donePtr. Either of keyPtrPtr and valuePtrPtr may be
+ * NULL, in which case the key/value is not made available to the caller.
+ *
+ * Side effects:
+ * The dictPtr object is converted to a dictionary type if it is not a
+ * dictionary already. The search context is initialised if the search
+ * has not finished. The dictionary's internal rep is Tcl_Preserve()d if
+ * the dictionary has at least one element.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DictObjFirst(
+ Tcl_Interp *interp, /* For error messages, or NULL if no error
+ * messages desired. */
+ Tcl_Obj *dictPtr, /* Dictionary to traverse. */
+ Tcl_DictSearch *searchPtr, /* Pointer to a dict search context. */
+ Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the first key
+ * written into, or NULL. */
+ Tcl_Obj **valuePtrPtr, /* Pointer to a variable to have the first
+ * value written into, or NULL.*/
+ int *donePtr) /* Pointer to a variable which will have a 1
+ * written into when there are no further
+ * values in the dictionary, or a 0
+ * otherwise. */
+{
+ Dict *dict;
+ ChainEntry *cPtr;
+
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ dict = DICT(dictPtr);
+ cPtr = dict->entryChainHead;
+ if (cPtr == NULL) {
+ searchPtr->epoch = -1;
+ *donePtr = 1;
+ } else {
+ *donePtr = 0;
+ searchPtr->dictionaryPtr = (Tcl_Dict) dict;
+ searchPtr->epoch = dict->epoch;
+ searchPtr->next = cPtr->nextPtr;
+ dict->refCount++;
+ if (keyPtrPtr != NULL) {
+ *keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
+ }
+ if (valuePtrPtr != NULL) {
+ *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry);
+ }
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjNext --
+ *
+ * Continue a traversal of a dictionary previously started with
+ * Tcl_DictObjFirst. This function is safe against concurrent
+ * modification of the underlying object (including type shimmering),
+ * treating such situations as if the search has terminated, though it is
+ * up to the caller to ensure that the object itself is not disposed
+ * until the search has finished. It is _not_ safe against modifications
+ * from other threads.
+ *
+ * Results:
+ * Updates the variables pointed to by keyPtrPtr, valuePtrPtr and
+ * donePtr. Either of keyPtrPtr and valuePtrPtr may be NULL, in which
+ * case the key/value is not made available to the caller.
+ *
+ * Side effects:
+ * Removes a reference to the dictionary's internal rep if the search
+ * terminates.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DictObjNext(
+ Tcl_DictSearch *searchPtr, /* Pointer to a hash search context. */
+ Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the first key
+ * written into, or NULL. */
+ Tcl_Obj **valuePtrPtr, /* Pointer to a variable to have the first
+ * value written into, or NULL.*/
+ int *donePtr) /* Pointer to a variable which will have a 1
+ * written into when there are no further
+ * values in the dictionary, or a 0
+ * otherwise. */
+{
+ ChainEntry *cPtr;
+
+ /*
+ * If the searh is done; we do no work.
+ */
+
+ if (searchPtr->epoch == -1) {
+ *donePtr = 1;
+ return;
+ }
+
+ /*
+ * Bail out if the dictionary has had any elements added, modified or
+ * removed. This *shouldn't* happen, but...
+ */
+
+ if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) {
+ Tcl_Panic("concurrent dictionary modification and search");
+ }
+
+ cPtr = searchPtr->next;
+ if (cPtr == NULL) {
+ Tcl_DictObjDone(searchPtr);
+ *donePtr = 1;
+ return;
+ }
+
+ searchPtr->next = cPtr->nextPtr;
+ *donePtr = 0;
+ if (keyPtrPtr != NULL) {
+ *keyPtrPtr = Tcl_GetHashKey(
+ &((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry);
+ }
+ if (valuePtrPtr != NULL) {
+ *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjDone --
+ *
+ * Call this if you want to stop a search before you reach the end of the
+ * dictionary (e.g. because of abnormal termination of the search). It
+ * need not be used if the search reaches its natural end (i.e. if either
+ * Tcl_DictObjFirst or Tcl_DictObjNext sets its donePtr variable to 1).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Removes a reference to the dictionary's internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DictObjDone(
+ Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */
+{
+ Dict *dict;
+
+ if (searchPtr->epoch != -1) {
+ searchPtr->epoch = -1;
+ dict = (Dict *) searchPtr->dictionaryPtr;
+ if (dict->refCount-- <= 1) {
+ DeleteDict(dict);
+ }
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjPutKeyList --
+ *
+ * Add a key...key,value pair to a dictionary tree. The main dictionary
+ * value must not be shared, though sub-dictionaries may be. All
+ * intermediate dictionaries on the path must exist.
+ *
+ * Results:
+ * A standard Tcl result. Note that in the error case, a message is left
+ * in interp unless that is NULL.
+ *
+ * Side effects:
+ * If the dictionary and any of its sub-dictionaries on the path have
+ * string representations, these are invalidated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DictObjPutKeyList(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ int keyc,
+ Tcl_Obj *const keyv[],
+ Tcl_Obj *valuePtr)
+{
+ Dict *dict;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ if (Tcl_IsShared(dictPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList");
+ }
+ if (keyc < 1) {
+ Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList");
+ }
+
+ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ dict = DICT(dictPtr);
+ hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
+ Tcl_IncrRefCount(valuePtr);
+ if (!isNew) {
+ Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
+
+ TclDecrRefCount(oldValuePtr);
+ }
+ Tcl_SetHashValue(hPtr, valuePtr);
+ InvalidateDictChain(dictPtr);
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DictObjRemoveKeyList --
+ *
+ * Remove a key...key,value pair from a dictionary tree (the value
+ * removed is implicit in the key path). The main dictionary value must
+ * not be shared, though sub-dictionaries may be. It is not an error if
+ * there is no value associated with the given key list, but all
+ * intermediate dictionaries on the key path must exist.
+ *
+ * Results:
+ * A standard Tcl result. Note that in the error case, a message is left
+ * in interp unless that is NULL.
+ *
+ * Side effects:
+ * If the dictionary and any of its sub-dictionaries on the key path have
+ * string representations, these are invalidated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DictObjRemoveKeyList(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ int keyc,
+ Tcl_Obj *const keyv[])
+{
+ Dict *dict;
+
+ if (Tcl_IsShared(dictPtr)) {
+ Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList");
+ }
+ if (keyc < 1) {
+ Tcl_Panic("%s called with empty key list", "Tcl_DictObjRemoveKeyList");
+ }
+
+ dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ dict = DICT(dictPtr);
+ DeleteChainEntry(dict, keyv[keyc-1]);
+ InvalidateDictChain(dictPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NewDictObj --
+ *
+ * This function is normally called when not debugging: i.e., when
+ * TCL_MEM_DEBUG is not defined. It creates a new dict object without any
+ * content.
+ *
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewDictObj.
+ *
+ * Results:
+ * A new dict object is returned; it has no keys defined in it. The new
+ * object's string representation is left NULL, and the ref count of the
+ * object is 0.
+ *
+ * Side Effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_NewDictObj(void)
+{
+#ifdef TCL_MEM_DEBUG
+ return Tcl_DbNewDictObj("unknown", 0);
+#else /* !TCL_MEM_DEBUG */
+
+ Tcl_Obj *dictPtr;
+ Dict *dict;
+
+ TclNewObj(dictPtr);
+ TclInvalidateStringRep(dictPtr);
+ dict = ckalloc(sizeof(Dict));
+ InitChainTable(dict);
+ dict->epoch = 0;
+ dict->chain = NULL;
+ dict->refCount = 1;
+ DICT(dictPtr) = dict;
+ dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ dictPtr->typePtr = &tclDictType;
+ return dictPtr;
+#endif
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbNewDictObj --
+ *
+ * This function is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. It creates new dict objects. It is the same
+ * as the Tcl_NewDictObj function above except that it calls
+ * Tcl_DbCkalloc directly with the file name and line number from its
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
+ *
+ * When TCL_MEM_DEBUG is not defined, this function just returns the
+ * result of calling Tcl_NewDictObj.
+ *
+ * Results:
+ * A new dict object is returned; it has no keys defined in it. The new
+ * object's string representation is left NULL, and the ref count of the
+ * object is 0.
+ *
+ * Side Effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_DbNewDictObj(
+ const char *file,
+ int line)
+{
+#ifdef TCL_MEM_DEBUG
+ Tcl_Obj *dictPtr;
+ Dict *dict;
+
+ TclDbNewObj(dictPtr, file, line);
+ TclInvalidateStringRep(dictPtr);
+ dict = ckalloc(sizeof(Dict));
+ InitChainTable(dict);
+ dict->epoch = 0;
+ dict->chain = NULL;
+ dict->refCount = 1;
+ DICT(dictPtr) = dict;
+ dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ dictPtr->typePtr = &tclDictType;
+ return dictPtr;
+#else /* !TCL_MEM_DEBUG */
+ return Tcl_NewDictObj();
+#endif
+}
+\f
+/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictCreateCmd --
+ *
+ * This function implements the "dict create" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictCreateCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictObj;
+ int i;
+
+ /*
+ * Must have an even number of arguments; note that number of preceding
+ * arguments (i.e. "dict create" is also even, which makes this much
+ * easier.)
+ */
+
+ if ((objc & 1) == 0) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?key value ...?");
+ return TCL_ERROR;
+ }
+
+ dictObj = Tcl_NewDictObj();
+ for (i=1 ; i<objc ; i+=2) {
+ /*
+ * The next command is assumed to never fail...
+ */
+ Tcl_DictObjPut(NULL, dictObj, objv[i], objv[i+1]);
+ }
+ Tcl_SetObjResult(interp, dictObj);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictGetCmd --
+ *
+ * This function implements the "dict get" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictGetCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *valuePtr = NULL;
+ int result;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Test for the special case of no keys, which returns a *list* of all
+ * key,value pairs. We produce a copy here because that makes subsequent
+ * list handling more efficient.
+ */
+
+ if (objc == 2) {
+ Tcl_Obj *keyPtr = NULL, *listPtr;
+ Tcl_DictSearch search;
+ int done;
+
+ result = Tcl_DictObjFirst(interp, objv[1], &search,
+ &keyPtr, &valuePtr, &done);
+ if (result != TCL_OK) {
+ return result;
+ }
+ listPtr = Tcl_NewListObj(0, NULL);
+ while (!done) {
+ /*
+ * Assume these won't fail as we have complete control over the
+ * types of things here.
+ */
+
+ Tcl_ListObjAppendElement(interp, listPtr, keyPtr);
+ Tcl_ListObjAppendElement(interp, listPtr, valuePtr);
+
+ Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
+ }
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Loop through the list of keys, looking up the key at the current index
+ * in the current dictionary each time. Once we've done the lookup, we set
+ * the current dictionary to be the value we looked up (in case the value
+ * was not the last one and we are going through a chain of searches.)
+ * Note that this loop always executes at least once.
+ */
+
+ dictPtr = TclTraceDictPath(interp, objv[1], objc-3,objv+2, DICT_PATH_READ);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+ result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (valuePtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(objv[objc-1])));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(objv[objc-1]), NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, valuePtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictReplaceCmd --
+ *
+ * This function implements the "dict replace" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictReplaceCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr;
+ int i;
+
+ if ((objc < 2) || (objc & 1)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?");
+ return TCL_ERROR;
+ }
+
+ dictPtr = objv[1];
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_IsShared(dictPtr)) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+ if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
+ }
+ for (i=2 ; i<objc ; i+=2) {
+ Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
+ }
+ Tcl_SetObjResult(interp, dictPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictRemoveCmd --
+ *
+ * This function implements the "dict remove" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictRemoveCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr;
+ int i;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
+ return TCL_ERROR;
+ }
+
+ dictPtr = objv[1];
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_IsShared(dictPtr)) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+ if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
+ }
+ for (i=2 ; i<objc ; i++) {
+ Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
+ }
+ Tcl_SetObjResult(interp, dictPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictMergeCmd --
+ *
+ * This function implements the "dict merge" Tcl command. See the user
+ * documentation for details on what it does, and TIP#163 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictMergeCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL;
+ int allocatedDict = 0;
+ int i, done;
+ Tcl_DictSearch search;
+
+ if (objc == 1) {
+ /*
+ * No dictionary arguments; return default (empty value).
+ */
+
+ return TCL_OK;
+ }
+
+ /*
+ * Make sure first argument is a dictionary.
+ */
+
+ targetObj = objv[1];
+ if (targetObj->typePtr != &tclDictType
+ && SetDictFromAny(interp, targetObj) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ /*
+ * Single argument, return it.
+ */
+
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
+
+ /*
+ * Normal behaviour: combining two (or more) dictionaries.
+ */
+
+ if (Tcl_IsShared(targetObj)) {
+ targetObj = Tcl_DuplicateObj(targetObj);
+ allocatedDict = 1;
+ }
+ for (i=2 ; i<objc ; i++) {
+ if (Tcl_DictObjFirst(interp, objv[i], &search, &keyObj, &valueObj,
+ &done) != TCL_OK) {
+ if (allocatedDict) {
+ TclDecrRefCount(targetObj);
+ }
+ return TCL_ERROR;
+ }
+ while (!done) {
+ /*
+ * Next line can't fail; already know we have a dictionary in
+ * targetObj.
+ */
+
+ Tcl_DictObjPut(NULL, targetObj, keyObj, valueObj);
+ Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
+ }
+ Tcl_DictObjDone(&search);
+ }
+ Tcl_SetObjResult(interp, targetObj);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictKeysCmd --
+ *
+ * This function implements the "dict keys" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictKeysCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *listPtr;
+ const char *pattern = NULL;
+
+ if (objc!=2 && objc!=3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * A direct check that we have a dictionary. We don't start the iteration
+ * yet because that might allocate memory or set locks that we do not
+ * need. [Bug 1705778, leak K04]
+ */
+
+ if (objv[1]->typePtr != &tclDictType
+ && SetDictFromAny(interp, objv[1]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ }
+ listPtr = Tcl_NewListObj(0, NULL);
+ if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
+ Tcl_Obj *valuePtr = NULL;
+
+ Tcl_DictObjGet(interp, objv[1], objv[2], &valuePtr);
+ if (valuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, listPtr, objv[2]);
+ }
+ } else {
+ Tcl_DictSearch search;
+ Tcl_Obj *keyPtr = NULL;
+ int done = 0;
+
+ /*
+ * At this point, we know we have a dictionary (or at least something
+ * that can be represented; it could theoretically have shimmered away
+ * when the pattern was fetched, but that shouldn't be damaging) so we
+ * can start the iteration process without checking for failures.
+ */
+
+ Tcl_DictObjFirst(NULL, objv[1], &search, &keyPtr, NULL, &done);
+ for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) {
+ if (!pattern || Tcl_StringMatch(TclGetString(keyPtr), pattern)) {
+ Tcl_ListObjAppendElement(NULL, listPtr, keyPtr);
+ }
+ }
+ Tcl_DictObjDone(&search);
+ }
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictValuesCmd --
+ *
+ * This function implements the "dict values" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictValuesCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *valuePtr = NULL, *listPtr;
+ Tcl_DictSearch search;
+ int done;
+ const char *pattern;
+
+ if (objc!=2 && objc!=3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_DictObjFirst(interp, objv[1], &search, NULL, &valuePtr,
+ &done) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ pattern = TclGetString(objv[2]);
+ } else {
+ pattern = NULL;
+ }
+ listPtr = Tcl_NewListObj(0, NULL);
+ for (; !done ; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
+ if (pattern==NULL || Tcl_StringMatch(TclGetString(valuePtr),pattern)) {
+ /*
+ * Assume this operation always succeeds.
+ */
+
+ Tcl_ListObjAppendElement(interp, listPtr, valuePtr);
+ }
+ }
+ Tcl_DictObjDone(&search);
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictSizeCmd --
+ *
+ * This function implements the "dict size" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictSizeCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int result, size;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
+ return TCL_ERROR;
+ }
+ result = Tcl_DictObjSize(interp, objv[1], &size);
+ if (result == TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ }
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictExistsCmd --
+ *
+ * This function implements the "dict exists" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictExistsCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *valuePtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?");
+ return TCL_ERROR;
+ }
+
+ dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2,
+ DICT_PATH_EXISTS);
+ if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT
+ || Tcl_DictObjGet(interp, dictPtr, objv[objc-1],
+ &valuePtr) != TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL));
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictInfoCmd --
+ *
+ * This function implements the "dict info" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictInfoCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr;
+ Dict *dict;
+ char *statsStr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
+ return TCL_ERROR;
+ }
+
+ dictPtr = objv[1];
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ dict = DICT(dictPtr);
+
+ statsStr = Tcl_HashStats(&dict->table);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
+ ckfree(statsStr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictIncrCmd --
+ *
+ * This function implements the "dict incr" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictIncrCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ int code = TCL_OK;
+ Tcl_Obj *dictPtr, *valuePtr = NULL;
+
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?increment?");
+ return TCL_ERROR;
+ }
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+ if (dictPtr == NULL) {
+ /*
+ * Variable didn't yet exist. Create new dictionary value.
+ */
+
+ dictPtr = Tcl_NewDictObj();
+ } else if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) {
+ /*
+ * Variable contents are not a dict, report error.
+ */
+
+ return TCL_ERROR;
+ }
+ if (Tcl_IsShared(dictPtr)) {
+ /*
+ * A little internals surgery to avoid copying a string rep that will
+ * soon be no good.
+ */
+
+ char *saved = dictPtr->bytes;
+ Tcl_Obj *oldPtr = dictPtr;
+
+ dictPtr->bytes = NULL;
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ oldPtr->bytes = saved;
+ }
+ if (valuePtr == NULL) {
+ /*
+ * Key not in dictionary. Create new key with increment as value.
+ */
+
+ if (objc == 4) {
+ /*
+ * Verify increment is an integer.
+ */
+
+ mp_int increment;
+
+ code = Tcl_GetBignumFromObj(interp, objv[3], &increment);
+ if (code != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (reading increment)");
+ } else {
+ /*
+ * Remember to dispose with the bignum as we're not actually
+ * using it directly. [Bug 2874678]
+ */
+
+ mp_clear(&increment);
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
+ }
+ } else {
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1));
+ }
+ } else {
+ /*
+ * Key in dictionary. Increment its value with minimum dup.
+ */
+
+ if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
+ }
+ if (objc == 4) {
+ code = TclIncrObj(interp, valuePtr, objv[3]);
+ } else {
+ Tcl_Obj *incrPtr;
+
+ TclNewIntObj(incrPtr, 1);
+ Tcl_IncrRefCount(incrPtr);
+ code = TclIncrObj(interp, valuePtr, incrPtr);
+ TclDecrRefCount(incrPtr);
+ }
+ }
+ if (code == TCL_OK) {
+ TclInvalidateStringRep(dictPtr);
+ valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG);
+ if (valuePtr == NULL) {
+ code = TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, valuePtr);
+ }
+ } else if (dictPtr->refCount == 0) {
+ TclDecrRefCount(dictPtr);
+ }
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictLappendCmd --
+ *
+ * This function implements the "dict lappend" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictLappendCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
+ int i, allocatedDict = 0, allocatedValue = 0;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
+ return TCL_ERROR;
+ }
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+ if (dictPtr == NULL) {
+ allocatedDict = 1;
+ dictPtr = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(dictPtr)) {
+ allocatedDict = 1;
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+
+ if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) {
+ if (allocatedDict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+
+ if (valuePtr == NULL) {
+ valuePtr = Tcl_NewListObj(objc-3, objv+3);
+ allocatedValue = 1;
+ } else {
+ if (Tcl_IsShared(valuePtr)) {
+ allocatedValue = 1;
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ }
+
+ for (i=3 ; i<objc ; i++) {
+ if (Tcl_ListObjAppendElement(interp, valuePtr,
+ objv[i]) != TCL_OK) {
+ if (allocatedValue) {
+ TclDecrRefCount(valuePtr);
+ }
+ if (allocatedDict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ if (allocatedValue) {
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
+ } else if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
+ TCL_LEAVE_ERR_MSG);
+ if (resultPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictAppendCmd --
+ *
+ * This function implements the "dict append" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictAppendCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
+ int i, allocatedDict = 0;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
+ return TCL_ERROR;
+ }
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+ if (dictPtr == NULL) {
+ allocatedDict = 1;
+ dictPtr = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(dictPtr)) {
+ allocatedDict = 1;
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+
+ if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) {
+ if (allocatedDict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+
+ if (valuePtr == NULL) {
+ TclNewObj(valuePtr);
+ } else if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ }
+
+ for (i=3 ; i<objc ; i++) {
+ Tcl_AppendObjToObj(valuePtr, objv[i]);
+ }
+
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
+ TCL_LEAVE_ERR_MSG);
+ if (resultPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictForNRCmd --
+ *
+ * These functions implement the "dict for" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictForNRCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
+ Tcl_Obj **varv, *keyObj, *valueObj;
+ Tcl_DictSearch *searchPtr;
+ int varc, done;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "{keyVarName valueVarName} dictionary script");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse arguments.
+ */
+
+ if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (varc != 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
+ return TCL_ERROR;
+ }
+ searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
+ if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
+ &done) != TCL_OK) {
+ TclStackFree(interp, searchPtr);
+ return TCL_ERROR;
+ }
+ if (done) {
+ TclStackFree(interp, searchPtr);
+ return TCL_OK;
+ }
+ TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ keyVarObj = varv[0];
+ valueVarObj = varv[1];
+ scriptObj = objv[3];
+
+ /*
+ * Make sure that these objects (which we need throughout the body of the
+ * loop) don't vanish. Note that the dictionary internal rep is locked
+ * internally so that updates, shimmering, etc are not a problem.
+ */
+
+ Tcl_IncrRefCount(keyVarObj);
+ Tcl_IncrRefCount(valueVarObj);
+ Tcl_IncrRefCount(scriptObj);
+
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
+
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ goto error;
+ }
+ TclDecrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ goto error;
+ }
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+ valueVarObj, scriptObj);
+ return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything on error.
+ */
+
+ error:
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(scriptObj);
+ Tcl_DictObjDone(searchPtr);
+ TclStackFree(interp, searchPtr);
+ return TCL_ERROR;
+}
+
+static int
+DictForLoopCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_DictSearch *searchPtr = data[0];
+ Tcl_Obj *keyVarObj = data[1];
+ Tcl_Obj *valueVarObj = data[2];
+ Tcl_Obj *scriptObj = data[3];
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
+
+ /*
+ * Process the result from the previous execution of the script body.
+ */
+
+ if (result == TCL_CONTINUE) {
+ result = TCL_OK;
+ } else if (result != TCL_OK) {
+ if (result == TCL_BREAK) {
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ } else if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"dict for\" body line %d)",
+ Tcl_GetErrorLine(interp)));
+ }
+ goto done;
+ }
+
+ /*
+ * Get the next mapping from the dictionary.
+ */
+
+ Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done);
+ if (done) {
+ Tcl_ResetResult(interp);
+ goto done;
+ }
+
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
+
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ result = TCL_ERROR;
+ goto done;
+ }
+ TclDecrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
+ valueVarObj, scriptObj);
+ return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything once the iterating is done.
+ */
+
+ done:
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(scriptObj);
+ Tcl_DictObjDone(searchPtr);
+ TclStackFree(interp, searchPtr);
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictMapNRCmd --
+ *
+ * These functions implement the "dict map" Tcl command. See the user
+ * documentation for details on what it does, and TIP#405 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictMapNRCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj **varv, *keyObj, *valueObj;
+ DictMapStorage *storagePtr;
+ int varc, done;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "{keyVarName valueVarName} dictionary script");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse arguments.
+ */
+
+ if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (varc != 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
+ return TCL_ERROR;
+ }
+ storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
+ if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
+ &valueObj, &done) != TCL_OK) {
+ TclStackFree(interp, storagePtr);
+ return TCL_ERROR;
+ }
+ if (done) {
+ /*
+ * Note that this exit leaves an empty value in the result (due to
+ * command calling conventions) but that is OK since an empty value is
+ * an empty dictionary.
+ */
+
+ TclStackFree(interp, storagePtr);
+ return TCL_OK;
+ }
+ TclNewObj(storagePtr->accumulatorObj);
+ TclListObjGetElements(NULL, objv[1], &varc, &varv);
+ storagePtr->keyVarObj = varv[0];
+ storagePtr->valueVarObj = varv[1];
+ storagePtr->scriptObj = objv[3];
+
+ /*
+ * Make sure that these objects (which we need throughout the body of the
+ * loop) don't vanish. Note that the dictionary internal rep is locked
+ * internally so that updates, shimmering, etc are not a problem.
+ */
+
+ Tcl_IncrRefCount(storagePtr->accumulatorObj);
+ Tcl_IncrRefCount(storagePtr->keyVarObj);
+ Tcl_IncrRefCount(storagePtr->valueVarObj);
+ Tcl_IncrRefCount(storagePtr->scriptObj);
+
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
+
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ goto error;
+ }
+ if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ goto error;
+ }
+ TclDecrRefCount(valueObj);
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
+ return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
+ iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything on error.
+ */
+
+ error:
+ TclDecrRefCount(storagePtr->keyVarObj);
+ TclDecrRefCount(storagePtr->valueVarObj);
+ TclDecrRefCount(storagePtr->scriptObj);
+ TclDecrRefCount(storagePtr->accumulatorObj);
+ Tcl_DictObjDone(&storagePtr->search);
+ TclStackFree(interp, storagePtr);
+ return TCL_ERROR;
+}
+
+static int
+DictMapLoopCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ DictMapStorage *storagePtr = data[0];
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
+
+ /*
+ * Process the result from the previous execution of the script body.
+ */
+
+ if (result == TCL_CONTINUE) {
+ result = TCL_OK;
+ } else if (result != TCL_OK) {
+ if (result == TCL_BREAK) {
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ } else if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"dict map\" body line %d)",
+ Tcl_GetErrorLine(interp)));
+ }
+ goto done;
+ } else {
+ keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (keyObj == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj,
+ Tcl_GetObjResult(interp));
+ }
+
+ /*
+ * Get the next mapping from the dictionary.
+ */
+
+ Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done);
+ if (done) {
+ Tcl_SetObjResult(interp, storagePtr->accumulatorObj);
+ goto done;
+ }
+
+ /*
+ * Stop the value from getting hit in any way by any traces on the key
+ * variable.
+ */
+
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(valueObj);
+ result = TCL_ERROR;
+ goto done;
+ }
+ TclDecrRefCount(valueObj);
+
+ /*
+ * Run the script.
+ */
+
+ TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
+ return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
+ iPtr->cmdFramePtr, 3);
+
+ /*
+ * For unwinding everything once the iterating is done.
+ */
+
+ done:
+ TclDecrRefCount(storagePtr->keyVarObj);
+ TclDecrRefCount(storagePtr->valueVarObj);
+ TclDecrRefCount(storagePtr->scriptObj);
+ TclDecrRefCount(storagePtr->accumulatorObj);
+ Tcl_DictObjDone(&storagePtr->search);
+ TclStackFree(interp, storagePtr);
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictSetCmd --
+ *
+ * This function implements the "dict set" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictSetCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *resultPtr;
+ int result, allocatedDict = 0;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...? value");
+ return TCL_ERROR;
+ }
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+ if (dictPtr == NULL) {
+ allocatedDict = 1;
+ dictPtr = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(dictPtr)) {
+ allocatedDict = 1;
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+
+ result = Tcl_DictObjPutKeyList(interp, dictPtr, objc-3, objv+2,
+ objv[objc-1]);
+ if (result != TCL_OK) {
+ if (allocatedDict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
+ TCL_LEAVE_ERR_MSG);
+ if (resultPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictUnsetCmd --
+ *
+ * This function implements the "dict unset" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictUnsetCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *dictPtr, *resultPtr;
+ int result, allocatedDict = 0;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...?");
+ return TCL_ERROR;
+ }
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+ if (dictPtr == NULL) {
+ allocatedDict = 1;
+ dictPtr = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(dictPtr)) {
+ allocatedDict = 1;
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+
+ result = Tcl_DictObjRemoveKeyList(interp, dictPtr, objc-2, objv+2);
+ if (result != TCL_OK) {
+ if (allocatedDict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
+ TCL_LEAVE_ERR_MSG);
+ if (resultPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictFilterCmd --
+ *
+ * This function implements the "dict filter" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictFilterCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ static const char *const filters[] = {
+ "key", "script", "value", NULL
+ };
+ enum FilterTypes {
+ FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
+ };
+ Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
+ Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
+ Tcl_DictSearch search;
+ int index, varc, done, result, satisfied;
+ const char *pattern;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
+ 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum FilterTypes) index) {
+ case FILTER_KEYS:
+ /*
+ * Create a dictionary whose keys all match a certain pattern.
+ */
+
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &keyObj, &valueObj, &done) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ /*
+ * Nothing to match, so return nothing (== empty dictionary).
+ */
+
+ Tcl_DictObjDone(&search);
+ return TCL_OK;
+ } else if (objc == 4) {
+ pattern = TclGetString(objv[3]);
+ resultObj = Tcl_NewDictObj();
+ if (TclMatchIsTrivial(pattern)) {
+ /*
+ * Must release the search lock here to prevent a memory leak
+ * since we are not exhausing the search. [Bug 1705778, leak
+ * K05]
+ */
+
+ Tcl_DictObjDone(&search);
+ Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj);
+ if (valueObj != NULL) {
+ Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj);
+ }
+ } else {
+ while (!done) {
+ if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
+ }
+ Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
+ }
+ }
+ } else {
+ /*
+ * Can't optimize this match for trivial globbing: would disturb
+ * order.
+ */
+
+ resultObj = Tcl_NewDictObj();
+ while (!done) {
+ int i;
+
+ for (i=3 ; i<objc ; i++) {
+ pattern = TclGetString(objv[i]);
+ if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
+ break; /* stop inner loop */
+ }
+ }
+ Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
+ }
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+ case FILTER_VALUES:
+ /*
+ * Create a dictionary whose values all match a certain pattern.
+ */
+
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &keyObj, &valueObj, &done) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ resultObj = Tcl_NewDictObj();
+ while (!done) {
+ int i;
+
+ for (i=3 ; i<objc ; i++) {
+ pattern = TclGetString(objv[i]);
+ if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
+ break; /* stop inner loop */
+ }
+ }
+ Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+ case FILTER_SCRIPT:
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "dictionary script {keyVarName valueVarName} filterScript");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create a dictionary whose key,value pairs all satisfy a script
+ * (i.e. get a true boolean result from its evaluation). Massive
+ * copying from the "dict for" implementation has occurred!
+ */
+
+ if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (varc != 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have exactly two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL);
+ return TCL_ERROR;
+ }
+ keyVarObj = varv[0];
+ valueVarObj = varv[1];
+ scriptObj = objv[4];
+
+ /*
+ * Make sure that these objects (which we need throughout the body of
+ * the loop) don't vanish. Note that the dictionary internal rep is
+ * locked internally so that updates, shimmering, etc are not a
+ * problem.
+ */
+
+ Tcl_IncrRefCount(keyVarObj);
+ Tcl_IncrRefCount(valueVarObj);
+ Tcl_IncrRefCount(scriptObj);
+
+ result = Tcl_DictObjFirst(interp, objv[1],
+ &search, &keyObj, &valueObj, &done);
+ if (result != TCL_OK) {
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(scriptObj);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewDictObj();
+
+ while (!done) {
+ /*
+ * Stop the value from getting hit in any way by any traces on the
+ * key variable.
+ */
+
+ Tcl_IncrRefCount(keyObj);
+ Tcl_IncrRefCount(valueObj);
+ if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_AddErrorInfo(interp,
+ "\n (\"dict filter\" filter script key variable)");
+ result = TCL_ERROR;
+ goto abnormalResult;
+ }
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_AddErrorInfo(interp,
+ "\n (\"dict filter\" filter script value variable)");
+ result = TCL_ERROR;
+ goto abnormalResult;
+ }
+
+ /*
+ * TIP #280. Make invoking context available to loop body.
+ */
+
+ result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 4);
+ switch (result) {
+ case TCL_OK:
+ boolObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(boolObj);
+ Tcl_ResetResult(interp);
+ if (Tcl_GetBooleanFromObj(interp, boolObj,
+ &satisfied) != TCL_OK) {
+ TclDecrRefCount(boolObj);
+ result = TCL_ERROR;
+ goto abnormalResult;
+ }
+ TclDecrRefCount(boolObj);
+ if (satisfied) {
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
+ }
+ break;
+ case TCL_BREAK:
+ /*
+ * Force loop termination by calling Tcl_DictObjDone; this
+ * makes the next Tcl_DictObjNext say there is nothing more to
+ * do.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_DictObjDone(&search);
+ /* FALLTHRU */
+ case TCL_CONTINUE:
+ result = TCL_OK;
+ break;
+ case TCL_ERROR:
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"dict filter\" script line %d)",
+ Tcl_GetErrorLine(interp)));
+ default:
+ goto abnormalResult;
+ }
+
+ TclDecrRefCount(keyObj);
+ TclDecrRefCount(valueObj);
+
+ Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
+ }
+
+ /*
+ * Stop holding a reference to these objects.
+ */
+
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(scriptObj);
+ Tcl_DictObjDone(&search);
+
+ if (result == TCL_OK) {
+ Tcl_SetObjResult(interp, resultObj);
+ } else {
+ TclDecrRefCount(resultObj);
+ }
+ return result;
+
+ abnormalResult:
+ Tcl_DictObjDone(&search);
+ TclDecrRefCount(keyObj);
+ TclDecrRefCount(valueObj);
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(scriptObj);
+ TclDecrRefCount(resultObj);
+ return result;
+ }
+ Tcl_Panic("unexpected fallthrough");
+ /* Control never reaches this point. */
+ return TCL_ERROR;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictUpdateCmd --
+ *
+ * This function implements the "dict update" Tcl command. See the user
+ * documentation for details on what it does, and TIP#212 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictUpdateCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *dictPtr, *objPtr;
+ int i, dummy;
+
+ if (objc < 5 || !(objc & 1)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "dictVarName key varName ?key varName ...? script");
+ return TCL_ERROR;
+ }
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(dictPtr);
+ for (i=2 ; i+2<objc ; i+=2) {
+ if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
+ TclDecrRefCount(dictPtr);
+ return TCL_ERROR;
+ }
+ if (objPtr == NULL) {
+ /* ??? */
+ Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0);
+ } else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(dictPtr);
+ return TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(dictPtr);
+
+ /*
+ * Execute the body after setting up the NRE handler to process the
+ * results.
+ */
+
+ objPtr = Tcl_NewListObj(objc-3, objv+2);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_IncrRefCount(objv[1]);
+ TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL);
+
+ return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
+}
+
+static int
+FinalizeDictUpdate(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *dictPtr, *objPtr, **objv;
+ Tcl_InterpState state;
+ int i, objc;
+ Tcl_Obj *varName = data[0];
+ Tcl_Obj *argsObj = data[1];
+
+ /*
+ * ErrorInfo handling.
+ */
+
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (body of \"dict update\")");
+ }
+
+ /*
+ * If the dictionary variable doesn't exist, drop everything silently.
+ */
+
+ dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0);
+ if (dictPtr == NULL) {
+ TclDecrRefCount(varName);
+ TclDecrRefCount(argsObj);
+ return result;
+ }
+
+ /*
+ * Double-check that it is still a dictionary.
+ */
+
+ state = Tcl_SaveInterpState(interp, result);
+ if (Tcl_DictObjSize(interp, dictPtr, &objc) != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+ TclDecrRefCount(varName);
+ TclDecrRefCount(argsObj);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_IsShared(dictPtr)) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ }
+
+ /*
+ * Write back the values from the variables, treating failure to read as
+ * an instruction to remove the key.
+ */
+
+ Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv);
+ for (i=0 ; i<objc ; i+=2) {
+ objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
+ if (objPtr == NULL) {
+ Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
+ } else if (objPtr == dictPtr) {
+ /*
+ * Someone is messing us around, trying to build a recursive
+ * structure. [Bug 1786481]
+ */
+
+ Tcl_DictObjPut(NULL, dictPtr, objv[i], Tcl_DuplicateObj(objPtr));
+ } else {
+ /* Shouldn't fail */
+ Tcl_DictObjPut(NULL, dictPtr, objv[i], objPtr);
+ }
+ }
+ TclDecrRefCount(argsObj);
+
+ /*
+ * Write the dictionary back to its variable.
+ */
+
+ if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DiscardInterpState(state);
+ TclDecrRefCount(varName);
+ return TCL_ERROR;
+ }
+
+ TclDecrRefCount(varName);
+ return Tcl_RestoreInterpState(interp, state);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictWithCmd --
+ *
+ * This function implements the "dict with" Tcl command. See the user
+ * documentation for details on what it does, and TIP#212 for the formal
+ * specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictWithCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dictVarName ?key ...? script");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the dictionary to open out.
+ */
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2);
+ if (keysPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(keysPtr);
+
+ /*
+ * Execute the body, while making the invoking context available to the
+ * loop body (TIP#280) and postponing the cleanup until later (NRE).
+ */
+
+ pathPtr = NULL;
+ if (objc > 3) {
+ pathPtr = Tcl_NewListObj(objc-3, objv+2);
+ Tcl_IncrRefCount(pathPtr);
+ }
+ Tcl_IncrRefCount(objv[1]);
+ TclNRAddCallback(interp, FinalizeDictWith, objv[1], keysPtr, pathPtr,
+ NULL);
+
+ return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
+}
+
+static int
+FinalizeDictWith(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj **pathv;
+ int pathc;
+ Tcl_InterpState state;
+ Tcl_Obj *varName = data[0];
+ Tcl_Obj *keysPtr = data[1];
+ Tcl_Obj *pathPtr = data[2];
+ Var *varPtr, *arrayPtr;
+
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")");
+ }
+
+ /*
+ * Save the result state; TDWF doesn't guarantee to not modify that on
+ * TCL_OK result.
+ */
+
+ state = Tcl_SaveInterpState(interp, result);
+ if (pathPtr != NULL) {
+ Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv);
+ } else {
+ pathc = 0;
+ pathv = NULL;
+ }
+
+ /*
+ * Pack from local variables back into the dictionary.
+ */
+
+ varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ result = TCL_ERROR;
+ } else {
+ result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1,
+ pathc, pathv, keysPtr);
+ }
+
+ /*
+ * Tidy up and return the real result (unless we had an error).
+ */
+
+ TclDecrRefCount(varName);
+ TclDecrRefCount(keysPtr);
+ if (pathPtr != NULL) {
+ TclDecrRefCount(pathPtr);
+ }
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+ return TCL_ERROR;
+ }
+ return Tcl_RestoreInterpState(interp, state);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDictWithInit --
+ *
+ * Part of the core of [dict with]. Pokes into a dictionary and converts
+ * the mappings there into assignments to (presumably) local variables.
+ * Returns a list of all the names that were mapped so that removal of
+ * either the variable or the dictionary entry won't surprise us when we
+ * come to stuffing everything back.
+ *
+ * Result:
+ * List of mapped names, or NULL if there was an error.
+ *
+ * Side effects:
+ * Assigns to variables, so potentially legion due to traces.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclDictWithInit(
+ Tcl_Interp *interp,
+ Tcl_Obj *dictPtr,
+ int pathc,
+ Tcl_Obj *const pathv[])
+{
+ Tcl_DictSearch s;
+ Tcl_Obj *keyPtr, *valPtr, *keysPtr;
+ int done;
+
+ if (pathc > 0) {
+ dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
+ DICT_PATH_READ);
+ if (dictPtr == NULL) {
+ return NULL;
+ }
+ }
+
+ /*
+ * Go over the list of keys and write each corresponding value to a
+ * variable in the current context with the same name. Also keep a copy of
+ * the keys so we can write back properly later on even if the dictionary
+ * has been structurally modified.
+ */
+
+ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
+ &done) != TCL_OK) {
+ return NULL;
+ }
+
+ TclNewObj(keysPtr);
+
+ for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
+ Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
+ if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(keysPtr);
+ Tcl_DictObjDone(&s);
+ return NULL;
+ }
+ }
+
+ return keysPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDictWithFinish --
+ *
+ * Part of the core of [dict with]. Reassembles the piece of the dict (in
+ * varName, location given by pathc/pathv) from the variables named in
+ * the keysPtr argument. NB, does not try to preserve errors or manage
+ * argument lifetimes.
+ *
+ * Result:
+ * TCL_OK if we succeeded, or TCL_ERROR if we failed.
+ *
+ * Side effects:
+ * Assigns to a variable, so potentially legion due to traces. Updates
+ * the dictionary in the named variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclDictWithFinish(
+ Tcl_Interp *interp, /* Command interpreter in which variable
+ * exists. Used for state management, traces
+ * and error reporting. */
+ Var *varPtr, /* Reference to the variable holding the
+ * dictionary. */
+ Var *arrayPtr, /* Reference to the array containing the
+ * variable, or NULL if the variable is a
+ * scalar. */
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. NULL if the 'index'
+ * parameter is >= 0 */
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ int index, /* Index into the local variable table of the
+ * variable, or -1. Only used when part1Ptr is
+ * NULL. */
+ int pathc, /* The number of elements in the path into the
+ * dictionary. */
+ Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */
+ Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is
+ * the result value from TclDictWithInit. */
+{
+ Tcl_Obj *dictPtr, *leafPtr, *valPtr;
+ int i, allocdict, keyc;
+ Tcl_Obj **keyv;
+
+ /*
+ * If the dictionary variable doesn't exist, drop everything silently.
+ */
+
+ dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ TCL_LEAVE_ERR_MSG, index);
+ if (dictPtr == NULL) {
+ return TCL_OK;
+ }
+
+ /*
+ * Double-check that it is still a dictionary.
+ */
+
+ if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (Tcl_IsShared(dictPtr)) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ allocdict = 1;
+ } else {
+ allocdict = 0;
+ }
+
+ if (pathc > 0) {
+ /*
+ * Want to get to the dictionary which we will update; need to do
+ * prepare-for-update de-sharing along the path *but* avoid generating
+ * an error on a non-existant path (we'll treat that the same as a
+ * non-existant variable. Luckily, the de-sharing operation isn't
+ * deeply damaging if we don't go on to update; it's just less than
+ * perfectly efficient (but no memory should be leaked).
+ */
+
+ leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
+ DICT_PATH_EXISTS | DICT_PATH_UPDATE);
+ if (leafPtr == NULL) {
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+ if (leafPtr == DICT_PATH_NON_EXISTENT) {
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_OK;
+ }
+ } else {
+ leafPtr = dictPtr;
+ }
+
+ /*
+ * Now process our updates on the leaf dictionary.
+ */
+
+ TclListObjGetElements(NULL, keysPtr, &keyc, &keyv);
+ for (i=0 ; i<keyc ; i++) {
+ valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
+ if (valPtr == NULL) {
+ Tcl_DictObjRemove(NULL, leafPtr, keyv[i]);
+ } else if (leafPtr == valPtr) {
+ /*
+ * Someone is messing us around, trying to build a recursive
+ * structure. [Bug 1786481]
+ */
+
+ Tcl_DictObjPut(NULL, leafPtr, keyv[i], Tcl_DuplicateObj(valPtr));
+ } else {
+ Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr);
+ }
+ }
+
+ /*
+ * Ensure that none of the dictionaries in the chain still have a string
+ * rep.
+ */
+
+ if (pathc > 0) {
+ InvalidateDictChain(leafPtr);
+ }
+
+ /*
+ * Write back the outermost dictionary to the variable.
+ */
+
+ if (TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ dictPtr, TCL_LEAVE_ERR_MSG, index) == NULL) {
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitDictCmd --
+ *
+ * This function is create the "dict" Tcl command. See the user
+ * documentation for details on what it does, and TIP#111 for the formal
+ * specification.
+ *
+ * Results:
+ * A Tcl command handle.
+ *
+ * Side effects:
+ * May advance compilation epoch.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclInitDictCmd(
+ Tcl_Interp *interp)
+{
+ return TclMakeEnsemble(interp, "dict", implementationMap);
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
