util/src/TclTk/tcl8.6.12/generic/tclDictObj.c

   1 /*
   2  * tclDictObj.c --
   3  *
   4  *      This file contains functions that implement the Tcl dict object type
   5  *      and its accessor command.
   6  *
   7  * Copyright (c) 2002-2010 by Donal K. Fellows.
   8  *
   9  * See the file "license.terms" for information on usage and redistribution of
  10  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  */
  12
  13 #include "tclInt.h"
  14 #include "tommath.h"
  15
  16 /*
  17  * Forward declaration.
  18  */
  19 struct Dict;
  20
  21 /*
  22  * Prototypes for functions defined later in this file:
  23  */
  24
  25 static void             DeleteDict(struct Dict *dict);
  26 static int              DictAppendCmd(ClientData dummy, Tcl_Interp *interp,
  27                             int objc, Tcl_Obj *const *objv);
  28 static int              DictCreateCmd(ClientData dummy, Tcl_Interp *interp,
  29                             int objc, Tcl_Obj *const *objv);
  30 static int              DictExistsCmd(ClientData dummy, Tcl_Interp *interp,
  31                             int objc, Tcl_Obj *const *objv);
  32 static int              DictFilterCmd(ClientData dummy, Tcl_Interp *interp,
  33                             int objc, Tcl_Obj *const *objv);
  34 static int              DictGetCmd(ClientData dummy, Tcl_Interp *interp,
  35                             int objc, Tcl_Obj *const *objv);
  36 static int              DictIncrCmd(ClientData dummy, Tcl_Interp *interp,
  37                             int objc, Tcl_Obj *const *objv);
  38 static int              DictInfoCmd(ClientData dummy, Tcl_Interp *interp,
  39                             int objc, Tcl_Obj *const *objv);
  40 static int              DictKeysCmd(ClientData dummy, Tcl_Interp *interp,
  41                             int objc, Tcl_Obj *const *objv);
  42 static int              DictLappendCmd(ClientData dummy, Tcl_Interp *interp,
  43                             int objc, Tcl_Obj *const *objv);
  44 static int              DictMergeCmd(ClientData dummy, Tcl_Interp *interp,
  45                             int objc, Tcl_Obj *const *objv);
  46 static int              DictRemoveCmd(ClientData dummy, Tcl_Interp *interp,
  47                             int objc, Tcl_Obj *const *objv);
  48 static int              DictReplaceCmd(ClientData dummy, Tcl_Interp *interp,
  49                             int objc, Tcl_Obj *const *objv);
  50 static int              DictSetCmd(ClientData dummy, Tcl_Interp *interp,
  51                             int objc, Tcl_Obj *const *objv);
  52 static int              DictSizeCmd(ClientData dummy, Tcl_Interp *interp,
  53                             int objc, Tcl_Obj *const *objv);
  54 static int              DictUnsetCmd(ClientData dummy, Tcl_Interp *interp,
  55                             int objc, Tcl_Obj *const *objv);
  56 static int              DictUpdateCmd(ClientData dummy, Tcl_Interp *interp,
  57                             int objc, Tcl_Obj *const *objv);
  58 static int              DictValuesCmd(ClientData dummy, Tcl_Interp *interp,
  59                             int objc, Tcl_Obj *const *objv);
  60 static int              DictWithCmd(ClientData dummy, Tcl_Interp *interp,
  61                             int objc, Tcl_Obj *const *objv);
  62 static void             DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
  63 static void             FreeDictInternalRep(Tcl_Obj *dictPtr);
  64 static void             InvalidateDictChain(Tcl_Obj *dictObj);
  65 static int              SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
  66 static void             UpdateStringOfDict(Tcl_Obj *dictPtr);
  67 static Tcl_HashEntry *  AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr);
  68 static inline void      InitChainTable(struct Dict *dict);
  69 static inline void      DeleteChainTable(struct Dict *dict);
  70 static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict,
  71                             Tcl_Obj *keyPtr, int *newPtr);
  72 static inline int       DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr);
  73 static Tcl_NRPostProc   FinalizeDictUpdate;
  74 static Tcl_NRPostProc   FinalizeDictWith;
  75 static Tcl_ObjCmdProc   DictForNRCmd;
  76 static Tcl_ObjCmdProc   DictMapNRCmd;
  77 static Tcl_NRPostProc   DictForLoopCallback;
  78 static Tcl_NRPostProc   DictMapLoopCallback;
  79
  80 /*
  81  * Table of dict subcommand names and implementations.
  82  */
  83
  84 static const EnsembleImplMap implementationMap[] = {
  85     {"append",  DictAppendCmd,  TclCompileDictAppendCmd, NULL, NULL, 0 },
  86     {"create",  DictCreateCmd,  TclCompileDictCreateCmd, NULL, NULL, 0 },
  87     {"exists",  DictExistsCmd,  TclCompileDictExistsCmd, NULL, NULL, 0 },
  88     {"filter",  DictFilterCmd,  NULL, NULL, NULL, 0 },
  89     {"for",     NULL,           TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
  90     {"get",     DictGetCmd,     TclCompileDictGetCmd, NULL, NULL, 0 },
  91     {"incr",    DictIncrCmd,    TclCompileDictIncrCmd, NULL, NULL, 0 },
  92     {"info",    DictInfoCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0 },
  93     {"keys",    DictKeysCmd,    TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
  94     {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
  95     {"map",     NULL,           TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
  96     {"merge",   DictMergeCmd,   TclCompileDictMergeCmd, NULL, NULL, 0 },
  97     {"remove",  DictRemoveCmd,  TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
  98     {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
  99     {"set",     DictSetCmd,     TclCompileDictSetCmd, NULL, NULL, 0 },
 100     {"size",    DictSizeCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0 },
 101     {"unset",   DictUnsetCmd,   TclCompileDictUnsetCmd, NULL, NULL, 0 },
 102     {"update",  DictUpdateCmd,  TclCompileDictUpdateCmd, NULL, NULL, 0 },
 103     {"values",  DictValuesCmd,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
 104     {"with",    DictWithCmd,    TclCompileDictWithCmd, NULL, NULL, 0 },
 105     {NULL, NULL, NULL, NULL, NULL, 0}
 106 };
 107
 108 /*
 109  * Internal representation of the entries in the hash table that backs a
 110  * dictionary.
 111  */
 112
 113 typedef struct ChainEntry {
 114     Tcl_HashEntry entry;
 115     struct ChainEntry *prevPtr;
 116     struct ChainEntry *nextPtr;
 117 } ChainEntry;
 118
 119 /*
 120  * Internal representation of a dictionary.
 121  *
 122  * The internal representation of a dictionary object is a hash table (with
 123  * Tcl_Objs for both keys and values), a reference count and epoch number for
 124  * detecting concurrent modifications of the dictionary, and a pointer to the
 125  * parent object (used when invalidating string reps of pathed dictionary
 126  * trees) which is NULL in normal use. The fact that hash tables know (with
 127  * appropriate initialisation) already about objects makes key management /so/
 128  * much easier!
 129  *
 130  * Reference counts are used to enable safe iteration across hashes while
 131  * allowing the type of the containing object to be modified.
 132  */
 133
 134 typedef struct Dict {
 135     Tcl_HashTable table;        /* Object hash table to store mapping in. */
 136     ChainEntry *entryChainHead; /* Linked list of all entries in the
 137                                  * dictionary. Used for doing traversal of the
 138                                  * entries in the order that they are
 139                                  * created. */
 140     ChainEntry *entryChainTail; /* Other end of linked list of all entries in
 141                                  * the dictionary. Used for doing traversal of
 142                                  * the entries in the order that they are
 143                                  * created. */
 144     int epoch;                  /* Epoch counter */
 145     size_t refCount;            /* Reference counter (see above) */
 146     Tcl_Obj *chain;             /* Linked list used for invalidating the
 147                                  * string representations of updated nested
 148                                  * dictionaries. */
 149 } Dict;
 150
 151 /*
 152  * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this
 153  * must be assignable as well as readable.
 154  */
 155
 156 #define DICT(dictObj)   ((dictObj)->internalRep.twoPtrValue.ptr1)
 157
 158 /*
 159  * The structure below defines the dictionary object type by means of
 160  * functions that can be invoked by generic object code.
 161  */
 162
 163 const Tcl_ObjType tclDictType = {
 164     "dict",
 165     FreeDictInternalRep,                /* freeIntRepProc */
 166     DupDictInternalRep,                 /* dupIntRepProc */
 167     UpdateStringOfDict,                 /* updateStringProc */
 168     SetDictFromAny                      /* setFromAnyProc */
 169 };
 170
 171 /*
 172  * The type of the specially adapted version of the Tcl_Obj*-containing hash
 173  * table defined in the tclObj.c code. This version differs in that it
 174  * allocates a bit more space in each hash entry in order to hold the pointers
 175  * used to keep the hash entries in a linked list.
 176  *
 177  * Note that this type of hash table is *only* suitable for direct use in
 178  * *this* file. Everything else should use the dict iterator API.
 179  */
 180
 181 static const Tcl_HashKeyType chainHashType = {
 182     TCL_HASH_KEY_TYPE_VERSION,
 183     0,
 184     TclHashObjKey,
 185     TclCompareObjKeys,
 186     AllocChainEntry,
 187     TclFreeObjEntry
 188 };
 189
 190 /*
 191  * Structure used in implementation of 'dict map' to hold the state that gets
 192  * passed between parts of the implementation.
 193  */
 194
 195 typedef struct {
 196     Tcl_Obj *keyVarObj;         /* The name of the variable that will have
 197                                  * keys assigned to it. */
 198     Tcl_Obj *valueVarObj;       /* The name of the variable that will have
 199                                  * values assigned to it. */
 200     Tcl_DictSearch search;      /* The dictionary search structure. */
 201     Tcl_Obj *scriptObj;         /* The script to evaluate each time through
 202                                  * the loop. */
 203     Tcl_Obj *accumulatorObj;    /* The dictionary used to accumulate the
 204                                  * results. */
 205 } DictMapStorage;
 206 \f
 207 /***** START OF FUNCTIONS IMPLEMENTING DICT CORE API *****/
 208
 209 /*
 210  *----------------------------------------------------------------------
 211  *
 212  * AllocChainEntry --
 213  *
 214  *      Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key, and
 215  *      which has a bit of extra space afterwards for storing pointers to the
 216  *      rest of the chain of entries (the extra pointers are left NULL).
 217  *
 218  * Results:
 219  *      The return value is a pointer to the created entry.
 220  *
 221  * Side effects:
 222  *      Increments the reference count on the object.
 223  *
 224  *----------------------------------------------------------------------
 225  */
 226
 227 static Tcl_HashEntry *
 228 AllocChainEntry(
 229     Tcl_HashTable *tablePtr,
 230     void *keyPtr)
 231 {
 232     Tcl_Obj *objPtr = keyPtr;
 233     ChainEntry *cPtr;
 234
 235     cPtr = ckalloc(sizeof(ChainEntry));
 236     cPtr->entry.key.objPtr = objPtr;
 237     Tcl_IncrRefCount(objPtr);
 238     cPtr->entry.clientData = NULL;
 239     cPtr->prevPtr = cPtr->nextPtr = NULL;
 240
 241     return &cPtr->entry;
 242 }
 243 \f
 244 /*
 245  * Helper functions that disguise most of the details relating to how the
 246  * linked list of hash entries is managed. In particular, these manage the
 247  * creation of the table and initializing of the chain, the deletion of the
 248  * table and chain, the adding of an entry to the chain, and the removal of an
 249  * entry from the chain.
 250  */
 251
 252 static inline void
 253 InitChainTable(
 254     Dict *dict)
 255 {
 256     Tcl_InitCustomHashTable(&dict->table, TCL_CUSTOM_PTR_KEYS,
 257             &chainHashType);
 258     dict->entryChainHead = dict->entryChainTail = NULL;
 259 }
 260
 261 static inline void
 262 DeleteChainTable(
 263     Dict *dict)
 264 {
 265     ChainEntry *cPtr;
 266
 267     for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
 268         Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
 269
 270         TclDecrRefCount(valuePtr);
 271     }
 272     Tcl_DeleteHashTable(&dict->table);
 273 }
 274
 275 static inline Tcl_HashEntry *
 276 CreateChainEntry(
 277     Dict *dict,
 278     Tcl_Obj *keyPtr,
 279     int *newPtr)
 280 {
 281     ChainEntry *cPtr = (ChainEntry *)
 282             Tcl_CreateHashEntry(&dict->table, keyPtr, newPtr);
 283
 284     /*
 285      * If this is a new entry in the hash table, stitch it into the chain.
 286      */
 287
 288     if (*newPtr) {
 289         cPtr->nextPtr = NULL;
 290         if (dict->entryChainHead == NULL) {
 291             cPtr->prevPtr = NULL;
 292             dict->entryChainHead = cPtr;
 293             dict->entryChainTail = cPtr;
 294         } else {
 295             cPtr->prevPtr = dict->entryChainTail;
 296             dict->entryChainTail->nextPtr = cPtr;
 297             dict->entryChainTail = cPtr;
 298         }
 299     }
 300
 301     return &cPtr->entry;
 302 }
 303
 304 static inline int
 305 DeleteChainEntry(
 306     Dict *dict,
 307     Tcl_Obj *keyPtr)
 308 {
 309     ChainEntry *cPtr = (ChainEntry *)
 310             Tcl_FindHashEntry(&dict->table, keyPtr);
 311
 312     if (cPtr == NULL) {
 313         return 0;
 314     } else {
 315         Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
 316
 317         TclDecrRefCount(valuePtr);
 318     }
 319
 320     /*
 321      * Unstitch from the chain.
 322      */
 323
 324     if (cPtr->nextPtr) {
 325         cPtr->nextPtr->prevPtr = cPtr->prevPtr;
 326     } else {
 327         dict->entryChainTail = cPtr->prevPtr;
 328     }
 329     if (cPtr->prevPtr) {
 330         cPtr->prevPtr->nextPtr = cPtr->nextPtr;
 331     } else {
 332         dict->entryChainHead = cPtr->nextPtr;
 333     }
 334
 335     Tcl_DeleteHashEntry(&cPtr->entry);
 336     return 1;
 337 }
 338 \f
 339 /*
 340  *----------------------------------------------------------------------
 341  *
 342  * DupDictInternalRep --
 343  *
 344  *      Initialize the internal representation of a dictionary Tcl_Obj to a
 345  *      copy of the internal representation of an existing dictionary object.
 346  *
 347  * Results:
 348  *      None.
 349  *
 350  * Side effects:
 351  *      "srcPtr"s dictionary internal rep pointer should not be NULL and we
 352  *      assume it is not NULL. We set "copyPtr"s internal rep to a pointer to
 353  *      a newly allocated dictionary rep that, in turn, points to "srcPtr"s
 354  *      key and value objects. Those objects are not actually copied but are
 355  *      shared between "srcPtr" and "copyPtr". The ref count of each key and
 356  *      value object is incremented.
 357  *
 358  *----------------------------------------------------------------------
 359  */
 360
 361 static void
 362 DupDictInternalRep(
 363     Tcl_Obj *srcPtr,
 364     Tcl_Obj *copyPtr)
 365 {
 366     Dict *oldDict = DICT(srcPtr);
 367     Dict *newDict = ckalloc(sizeof(Dict));
 368     ChainEntry *cPtr;
 369
 370     /*
 371      * Copy values across from the old hash table.
 372      */
 373
 374     InitChainTable(newDict);
 375     for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
 376         Tcl_Obj *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
 377         Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
 378         int n;
 379         Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n);
 380
 381         /*
 382          * Fill in the contents.
 383          */
 384
 385         Tcl_SetHashValue(hPtr, valuePtr);
 386         Tcl_IncrRefCount(valuePtr);
 387     }
 388
 389     /*
 390      * Initialise other fields.
 391      */
 392
 393     newDict->epoch = 0;
 394     newDict->chain = NULL;
 395     newDict->refCount = 1;
 396
 397     /*
 398      * Store in the object.
 399      */
 400
 401     DICT(copyPtr) = newDict;
 402     copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
 403     copyPtr->typePtr = &tclDictType;
 404 }
 405 \f
 406 /*
 407  *----------------------------------------------------------------------
 408  *
 409  * FreeDictInternalRep --
 410  *
 411  *      Deallocate the storage associated with a dictionary object's internal
 412  *      representation.
 413  *
 414  * Results:
 415  *      None
 416  *
 417  * Side effects:
 418  *      Frees the memory holding the dictionary's internal hash table unless
 419  *      it is locked by an iteration going over it.
 420  *
 421  *----------------------------------------------------------------------
 422  */
 423
 424 static void
 425 FreeDictInternalRep(
 426     Tcl_Obj *dictPtr)
 427 {
 428     Dict *dict = DICT(dictPtr);
 429
 430     if (dict->refCount-- <= 1) {
 431         DeleteDict(dict);
 432     }
 433     dictPtr->typePtr = NULL;
 434 }
 435 \f
 436 /*
 437  *----------------------------------------------------------------------
 438  *
 439  * DeleteDict --
 440  *
 441  *      Delete the structure that is used to implement a dictionary's internal
 442  *      representation. Called when either the dictionary object loses its
 443  *      internal representation or when the last iteration over the dictionary
 444  *      completes.
 445  *
 446  * Results:
 447  *      None
 448  *
 449  * Side effects:
 450  *      Decrements the reference count of all key and value objects in the
 451  *      dictionary, which may free them.
 452  *
 453  *----------------------------------------------------------------------
 454  */
 455
 456 static void
 457 DeleteDict(
 458     Dict *dict)
 459 {
 460     DeleteChainTable(dict);
 461     ckfree(dict);
 462 }
 463 \f
 464 /*
 465  *----------------------------------------------------------------------
 466  *
 467  * UpdateStringOfDict --
 468  *
 469  *      Update the string representation for a dictionary object. Note: This
 470  *      function does not invalidate an existing old string rep so storage
 471  *      will be lost if this has not already been done. This code is based on
 472  *      UpdateStringOfList in tclListObj.c
 473  *
 474  * Results:
 475  *      None.
 476  *
 477  * Side effects:
 478  *      The object's string is set to a valid string that results from the
 479  *      dict-to-string conversion. This string will be empty if the dictionary
 480  *      has no key/value pairs. The dictionary internal representation should
 481  *      not be NULL and we assume it is not NULL.
 482  *
 483  *----------------------------------------------------------------------
 484  */
 485
 486 static void
 487 UpdateStringOfDict(
 488     Tcl_Obj *dictPtr)
 489 {
 490 #define LOCAL_SIZE 64
 491     char localFlags[LOCAL_SIZE], *flagPtr = NULL;
 492     Dict *dict = DICT(dictPtr);
 493     ChainEntry *cPtr;
 494     Tcl_Obj *keyPtr, *valuePtr;
 495     int i, length, bytesNeeded = 0;
 496     const char *elem;
 497     char *dst;
 498
 499     /*
 500      * This field is the most useful one in the whole hash structure, and it
 501      * is not exposed by any API function...
 502      */
 503
 504     int numElems = dict->table.numEntries * 2;
 505
 506     /* Handle empty list case first, simplifies what follows */
 507     if (numElems == 0) {
 508         dictPtr->bytes = tclEmptyStringRep;
 509         dictPtr->length = 0;
 510         return;
 511     }
 512
 513     /*
 514      * Pass 1: estimate space, gather flags.
 515      */
 516
 517     if (numElems <= LOCAL_SIZE) {
 518         flagPtr = localFlags;
 519     } else {
 520         flagPtr = ckalloc(numElems);
 521     }
 522     for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
 523         /*
 524          * Assume that cPtr is never NULL since we know the number of array
 525          * elements already.
 526          */
 527
 528         flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
 529         keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
 530         elem = TclGetStringFromObj(keyPtr, &length);
 531         bytesNeeded += TclScanElement(elem, length, flagPtr+i);
 532         if (bytesNeeded < 0) {
 533             Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
 534         }
 535
 536         flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
 537         valuePtr = Tcl_GetHashValue(&cPtr->entry);
 538         elem = TclGetStringFromObj(valuePtr, &length);
 539         bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
 540         if (bytesNeeded < 0) {
 541             Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
 542         }
 543     }
 544     if (bytesNeeded > INT_MAX - numElems + 1) {
 545         Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
 546     }
 547     bytesNeeded += numElems;
 548
 549     /*
 550      * Pass 2: copy into string rep buffer.
 551      */
 552
 553     dictPtr->length = bytesNeeded - 1;
 554     dictPtr->bytes = ckalloc(bytesNeeded);
 555     dst = dictPtr->bytes;
 556     for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
 557         flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
 558         keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
 559         elem = TclGetStringFromObj(keyPtr, &length);
 560         dst += TclConvertElement(elem, length, dst, flagPtr[i]);
 561         *dst++ = ' ';
 562
 563         flagPtr[i+1] |= TCL_DONT_QUOTE_HASH;
 564         valuePtr = Tcl_GetHashValue(&cPtr->entry);
 565         elem = TclGetStringFromObj(valuePtr, &length);
 566         dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
 567         *dst++ = ' ';
 568     }
 569     dictPtr->bytes[dictPtr->length] = '\0';
 570
 571     if (flagPtr != localFlags) {
 572         ckfree(flagPtr);
 573     }
 574 }
 575 \f
 576 /*
 577  *----------------------------------------------------------------------
 578  *
 579  * SetDictFromAny --
 580  *
 581  *      Convert a non-dictionary object into a dictionary object. This code is
 582  *      very closely related to SetListFromAny in tclListObj.c but does not
 583  *      actually guarantee that a dictionary object will have a string rep (as
 584  *      conversions from lists are handled with a special case.)
 585  *
 586  * Results:
 587  *      A standard Tcl result.
 588  *
 589  * Side effects:
 590  *      If the string can be converted, it loses any old internal
 591  *      representation that it had and gains a dictionary's internalRep.
 592  *
 593  *----------------------------------------------------------------------
 594  */
 595
 596 static int
 597 SetDictFromAny(
 598     Tcl_Interp *interp,
 599     Tcl_Obj *objPtr)
 600 {
 601     Tcl_HashEntry *hPtr;
 602     int isNew;
 603     Dict *dict = ckalloc(sizeof(Dict));
 604
 605     InitChainTable(dict);
 606
 607     /*
 608      * Since lists and dictionaries have very closely-related string
 609      * representations (i.e. the same parsing code) we can safely special-case
 610      * the conversion from lists to dictionaries.
 611      */
 612
 613     if (objPtr->typePtr == &tclListType) {
 614         int objc, i;
 615         Tcl_Obj **objv;
 616
 617         /* Cannot fail, we already know the Tcl_ObjType is "list". */
 618         TclListObjGetElements(NULL, objPtr, &objc, &objv);
 619         if (objc & 1) {
 620             goto missingValue;
 621         }
 622
 623         for (i=0 ; i<objc ; i+=2) {
 624
 625             /* Store key and value in the hash table we're building. */
 626             hPtr = CreateChainEntry(dict, objv[i], &isNew);
 627             if (!isNew) {
 628                 Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
 629
 630                 /*
 631                  * Not really a well-formed dictionary as there are duplicate
 632                  * keys, so better get the string rep here so that we can
 633                  * convert back.
 634                  */
 635
 636                 (void) Tcl_GetString(objPtr);
 637
 638                 TclDecrRefCount(discardedValue);
 639             }
 640             Tcl_SetHashValue(hPtr, objv[i+1]);
 641             Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
 642         }
 643     } else {
 644         int length;
 645         const char *nextElem = TclGetStringFromObj(objPtr, &length);
 646         const char *limit = (nextElem + length);
 647
 648         while (nextElem < limit) {
 649             Tcl_Obj *keyPtr, *valuePtr;
 650             const char *elemStart;
 651             int elemSize, literal;
 652
 653             if (TclFindDictElement(interp, nextElem, (limit - nextElem),
 654                     &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
 655                 goto errorInFindDictElement;
 656             }
 657             if (elemStart == limit) {
 658                 break;
 659             }
 660             if (nextElem == limit) {
 661                 goto missingValue;
 662             }
 663
 664             if (literal) {
 665                 TclNewStringObj(keyPtr, elemStart, elemSize);
 666             } else {
 667                 /* Avoid double copy */
 668                 TclNewObj(keyPtr);
 669                 keyPtr->bytes = ckalloc((unsigned) elemSize + 1);
 670                 keyPtr->length = TclCopyAndCollapse(elemSize, elemStart,
 671                         keyPtr->bytes);
 672             }
 673
 674             if (TclFindDictElement(interp, nextElem, (limit - nextElem),
 675                     &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
 676                 TclDecrRefCount(keyPtr);
 677                 goto errorInFindDictElement;
 678             }
 679
 680             if (literal) {
 681                 TclNewStringObj(valuePtr, elemStart, elemSize);
 682             } else {
 683                 /* Avoid double copy */
 684                 TclNewObj(valuePtr);
 685                 valuePtr->bytes = ckalloc((unsigned) elemSize + 1);
 686                 valuePtr->length = TclCopyAndCollapse(elemSize, elemStart,
 687                         valuePtr->bytes);
 688             }
 689
 690             /* Store key and value in the hash table we're building. */
 691             hPtr = CreateChainEntry(dict, keyPtr, &isNew);
 692             if (!isNew) {
 693                 Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
 694
 695                 TclDecrRefCount(keyPtr);
 696                 TclDecrRefCount(discardedValue);
 697             }
 698             Tcl_SetHashValue(hPtr, valuePtr);
 699             Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
 700         }
 701     }
 702
 703     /*
 704      * Free the old internalRep before setting the new one. We do this as late
 705      * as possible to allow the conversion code, in particular
 706      * Tcl_GetStringFromObj, to use that old internalRep.
 707      */
 708
 709     TclFreeIntRep(objPtr);
 710     dict->epoch = 0;
 711     dict->chain = NULL;
 712     dict->refCount = 1;
 713     DICT(objPtr) = dict;
 714     objPtr->internalRep.twoPtrValue.ptr2 = NULL;
 715     objPtr->typePtr = &tclDictType;
 716     return TCL_OK;
 717
 718   missingValue:
 719     if (interp != NULL) {
 720         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 721                 "missing value to go with key", -1));
 722         Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
 723     }
 724   errorInFindDictElement:
 725     DeleteChainTable(dict);
 726     ckfree(dict);
 727     return TCL_ERROR;
 728 }
 729 \f
 730 /*
 731  *----------------------------------------------------------------------
 732  *
 733  * TclTraceDictPath --
 734  *
 735  *      Trace through a tree of dictionaries using the array of keys given. If
 736  *      the flags argument has the DICT_PATH_UPDATE flag is set, a
 737  *      backward-pointing chain of dictionaries is also built (in the Dict's
 738  *      chain field) and the chained dictionaries are made into unshared
 739  *      dictionaries (if they aren't already.)
 740  *
 741  * Results:
 742  *      The object at the end of the path, or NULL if there was an error. Note
 743  *      that this it is an error for an intermediate dictionary on the path to
 744  *      not exist. If the flags argument has the DICT_PATH_EXISTS set, a
 745  *      non-existent path gives a DICT_PATH_NON_EXISTENT result.
 746  *
 747  * Side effects:
 748  *      If the flags argument is zero or DICT_PATH_EXISTS, there are no side
 749  *      effects (other than potential conversion of objects to dictionaries.)
 750  *      If the flags argument is DICT_PATH_UPDATE, the following additional
 751  *      side effects occur. Shared dictionaries along the path are converted
 752  *      into unshared objects, and a backward-pointing chain is built using
 753  *      the chain fields of the dictionaries (for easy invalidation of string
 754  *      representations using InvalidateDictChain). If the flags argument has
 755  *      the DICT_PATH_CREATE bits set (and not the DICT_PATH_EXISTS bit),
 756  *      non-existant keys will be inserted with a value of an empty
 757  *      dictionary, resulting in the path being built.
 758  *
 759  *----------------------------------------------------------------------
 760  */
 761
 762 Tcl_Obj *
 763 TclTraceDictPath(
 764     Tcl_Interp *interp,
 765     Tcl_Obj *dictPtr,
 766     int keyc,
 767     Tcl_Obj *const keyv[],
 768     int flags)
 769 {
 770     Dict *dict, *newDict;
 771     int i;
 772
 773     if (dictPtr->typePtr != &tclDictType
 774             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
 775         return NULL;
 776     }
 777     dict = DICT(dictPtr);
 778     if (flags & DICT_PATH_UPDATE) {
 779         dict->chain = NULL;
 780     }
 781
 782     for (i=0 ; i<keyc ; i++) {
 783         Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&dict->table, keyv[i]);
 784         Tcl_Obj *tmpObj;
 785
 786         if (hPtr == NULL) {
 787             int isNew;                  /* Dummy */
 788
 789             if (flags & DICT_PATH_EXISTS) {
 790                 return DICT_PATH_NON_EXISTENT;
 791             }
 792             if ((flags & DICT_PATH_CREATE) != DICT_PATH_CREATE) {
 793                 if (interp != NULL) {
 794                     Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 795                             "key \"%s\" not known in dictionary",
 796                             TclGetString(keyv[i])));
 797                     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
 798                             TclGetString(keyv[i]), NULL);
 799                 }
 800                 return NULL;
 801             }
 802
 803             /*
 804              * The next line should always set isNew to 1.
 805              */
 806
 807             hPtr = CreateChainEntry(dict, keyv[i], &isNew);
 808             tmpObj = Tcl_NewDictObj();
 809             Tcl_IncrRefCount(tmpObj);
 810             Tcl_SetHashValue(hPtr, tmpObj);
 811         } else {
 812             tmpObj = Tcl_GetHashValue(hPtr);
 813             if (tmpObj->typePtr != &tclDictType
 814                     && SetDictFromAny(interp, tmpObj) != TCL_OK) {
 815                 return NULL;
 816             }
 817         }
 818
 819         newDict = DICT(tmpObj);
 820         if (flags & DICT_PATH_UPDATE) {
 821             if (Tcl_IsShared(tmpObj)) {
 822                 TclDecrRefCount(tmpObj);
 823                 tmpObj = Tcl_DuplicateObj(tmpObj);
 824                 Tcl_IncrRefCount(tmpObj);
 825                 Tcl_SetHashValue(hPtr, tmpObj);
 826                 dict->epoch++;
 827                 newDict = DICT(tmpObj);
 828             }
 829
 830             newDict->chain = dictPtr;
 831         }
 832         dict = newDict;
 833         dictPtr = tmpObj;
 834     }
 835     return dictPtr;
 836 }
 837 \f
 838 /*
 839  *----------------------------------------------------------------------
 840  *
 841  * InvalidateDictChain --
 842  *
 843  *      Go through a dictionary chain (built by an updating invokation of
 844  *      TclTraceDictPath) and invalidate the string representations of all the
 845  *      dictionaries on the chain.
 846  *
 847  * Results:
 848  *      None
 849  *
 850  * Side effects:
 851  *      String reps are invalidated and epoch counters (for detecting illegal
 852  *      concurrent modifications) are updated through the chain of updated
 853  *      dictionaries.
 854  *
 855  *----------------------------------------------------------------------
 856  */
 857
 858 static void
 859 InvalidateDictChain(
 860     Tcl_Obj *dictObj)
 861 {
 862     Dict *dict = DICT(dictObj);
 863
 864     do {
 865         TclInvalidateStringRep(dictObj);
 866         dict->epoch++;
 867         dictObj = dict->chain;
 868         if (dictObj == NULL) {
 869             break;
 870         }
 871         dict->chain = NULL;
 872         dict = DICT(dictObj);
 873     } while (dict != NULL);
 874 }
 875 \f
 876 /*
 877  *----------------------------------------------------------------------
 878  *
 879  * Tcl_DictObjPut --
 880  *
 881  *      Add a key,value pair to a dictionary, or update the value for a key if
 882  *      that key already has a mapping in the dictionary.
 883  *
 884  * Results:
 885  *      A standard Tcl result.
 886  *
 887  * Side effects:
 888  *      The object pointed to by dictPtr is converted to a dictionary if it is
 889  *      not already one, and any string representation that it has is
 890  *      invalidated.
 891  *
 892  *----------------------------------------------------------------------
 893  */
 894
 895 int
 896 Tcl_DictObjPut(
 897     Tcl_Interp *interp,
 898     Tcl_Obj *dictPtr,
 899     Tcl_Obj *keyPtr,
 900     Tcl_Obj *valuePtr)
 901 {
 902     Dict *dict;
 903     Tcl_HashEntry *hPtr;
 904     int isNew;
 905
 906     if (Tcl_IsShared(dictPtr)) {
 907         Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
 908     }
 909
 910     if (dictPtr->typePtr != &tclDictType
 911             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
 912         return TCL_ERROR;
 913     }
 914
 915     if (dictPtr->bytes != NULL) {
 916         TclInvalidateStringRep(dictPtr);
 917     }
 918     dict = DICT(dictPtr);
 919     hPtr = CreateChainEntry(dict, keyPtr, &isNew);
 920     Tcl_IncrRefCount(valuePtr);
 921     if (!isNew) {
 922         Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
 923
 924         TclDecrRefCount(oldValuePtr);
 925     }
 926     Tcl_SetHashValue(hPtr, valuePtr);
 927     dict->epoch++;
 928     return TCL_OK;
 929 }
 930 \f
 931 /*
 932  *----------------------------------------------------------------------
 933  *
 934  * Tcl_DictObjGet --
 935  *
 936  *      Given a key, get its value from the dictionary (or NULL if key is not
 937  *      found in dictionary.)
 938  *
 939  * Results:
 940  *      A standard Tcl result. The variable pointed to by valuePtrPtr is
 941  *      updated with the value for the key. Note that it is not an error for
 942  *      the key to have no mapping in the dictionary.
 943  *
 944  * Side effects:
 945  *      The object pointed to by dictPtr is converted to a dictionary if it is
 946  *      not already one.
 947  *
 948  *----------------------------------------------------------------------
 949  */
 950
 951 int
 952 Tcl_DictObjGet(
 953     Tcl_Interp *interp,
 954     Tcl_Obj *dictPtr,
 955     Tcl_Obj *keyPtr,
 956     Tcl_Obj **valuePtrPtr)
 957 {
 958     Dict *dict;
 959     Tcl_HashEntry *hPtr;
 960
 961     if (dictPtr->typePtr != &tclDictType
 962             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
 963         *valuePtrPtr = NULL;
 964         return TCL_ERROR;
 965     }
 966
 967     dict = DICT(dictPtr);
 968     hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
 969     if (hPtr == NULL) {
 970         *valuePtrPtr = NULL;
 971     } else {
 972         *valuePtrPtr = Tcl_GetHashValue(hPtr);
 973     }
 974     return TCL_OK;
 975 }
 976 \f
 977 /*
 978  *----------------------------------------------------------------------
 979  *
 980  * Tcl_DictObjRemove --
 981  *
 982  *      Remove the key,value pair with the given key from the dictionary; the
 983  *      key does not need to be present in the dictionary.
 984  *
 985  * Results:
 986  *      A standard Tcl result.
 987  *
 988  * Side effects:
 989  *      The object pointed to by dictPtr is converted to a dictionary if it is
 990  *      not already one, and any string representation that it has is
 991  *      invalidated.
 992  *
 993  *----------------------------------------------------------------------
 994  */
 995
 996 int
 997 Tcl_DictObjRemove(
 998     Tcl_Interp *interp,
 999     Tcl_Obj *dictPtr,
1000     Tcl_Obj *keyPtr)
1001 {
1002     Dict *dict;
1003
1004     if (Tcl_IsShared(dictPtr)) {
1005         Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
1006     }
1007
1008     if (dictPtr->typePtr != &tclDictType
1009             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
1010         return TCL_ERROR;
1011     }
1012
1013     dict = DICT(dictPtr);
1014     if (DeleteChainEntry(dict, keyPtr)) {
1015         if (dictPtr->bytes != NULL) {
1016             TclInvalidateStringRep(dictPtr);
1017         }
1018         dict->epoch++;
1019     }
1020     return TCL_OK;
1021 }
1022 \f
1023 /*
1024  *----------------------------------------------------------------------
1025  *
1026  * Tcl_DictObjSize --
1027  *
1028  *      How many key,value pairs are there in the dictionary?
1029  *
1030  * Results:
1031  *      A standard Tcl result. Updates the variable pointed to by sizePtr with
1032  *      the number of key,value pairs in the dictionary.
1033  *
1034  * Side effects:
1035  *      The dictPtr object is converted to a dictionary type if it is not a
1036  *      dictionary already.
1037  *
1038  *----------------------------------------------------------------------
1039  */
1040
1041 int
1042 Tcl_DictObjSize(
1043     Tcl_Interp *interp,
1044     Tcl_Obj *dictPtr,
1045     int *sizePtr)
1046 {
1047     Dict *dict;
1048
1049     if (dictPtr->typePtr != &tclDictType
1050             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
1051         return TCL_ERROR;
1052     }
1053
1054     dict = DICT(dictPtr);
1055     *sizePtr = dict->table.numEntries;
1056     return TCL_OK;
1057 }
1058 \f
1059 /*
1060  *----------------------------------------------------------------------
1061  *
1062  * Tcl_DictObjFirst --
1063  *
1064  *      Start a traversal of the dictionary. Caller must supply the search
1065  *      context, pointers for returning key and value, and a pointer to allow
1066  *      indication of whether the dictionary has been traversed (i.e. the
1067  *      dictionary is empty). The order of traversal is undefined.
1068  *
1069  * Results:
1070  *      A standard Tcl result. Updates the variables pointed to by keyPtrPtr,
1071  *      valuePtrPtr and donePtr. Either of keyPtrPtr and valuePtrPtr may be
1072  *      NULL, in which case the key/value is not made available to the caller.
1073  *
1074  * Side effects:
1075  *      The dictPtr object is converted to a dictionary type if it is not a
1076  *      dictionary already. The search context is initialised if the search
1077  *      has not finished. The dictionary's internal rep is Tcl_Preserve()d if
1078  *      the dictionary has at least one element.
1079  *
1080  *----------------------------------------------------------------------
1081  */
1082
1083 int
1084 Tcl_DictObjFirst(
1085     Tcl_Interp *interp,         /* For error messages, or NULL if no error
1086                                  * messages desired. */
1087     Tcl_Obj *dictPtr,           /* Dictionary to traverse. */
1088     Tcl_DictSearch *searchPtr,  /* Pointer to a dict search context. */
1089     Tcl_Obj **keyPtrPtr,        /* Pointer to a variable to have the first key
1090                                  * written into, or NULL. */
1091     Tcl_Obj **valuePtrPtr,      /* Pointer to a variable to have the first
1092                                  * value written into, or NULL.*/
1093     int *donePtr)               /* Pointer to a variable which will have a 1
1094                                  * written into when there are no further
1095                                  * values in the dictionary, or a 0
1096                                  * otherwise. */
1097 {
1098     Dict *dict;
1099     ChainEntry *cPtr;
1100
1101     if (dictPtr->typePtr != &tclDictType
1102             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
1103         return TCL_ERROR;
1104     }
1105
1106     dict = DICT(dictPtr);
1107     cPtr = dict->entryChainHead;
1108     if (cPtr == NULL) {
1109         searchPtr->epoch = -1;
1110         *donePtr = 1;
1111     } else {
1112         *donePtr = 0;
1113         searchPtr->dictionaryPtr = (Tcl_Dict) dict;
1114         searchPtr->epoch = dict->epoch;
1115         searchPtr->next = cPtr->nextPtr;
1116         dict->refCount++;
1117         if (keyPtrPtr != NULL) {
1118             *keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
1119         }
1120         if (valuePtrPtr != NULL) {
1121             *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry);
1122         }
1123     }
1124     return TCL_OK;
1125 }
1126 \f
1127 /*
1128  *----------------------------------------------------------------------
1129  *
1130  * Tcl_DictObjNext --
1131  *
1132  *      Continue a traversal of a dictionary previously started with
1133  *      Tcl_DictObjFirst. This function is safe against concurrent
1134  *      modification of the underlying object (including type shimmering),
1135  *      treating such situations as if the search has terminated, though it is
1136  *      up to the caller to ensure that the object itself is not disposed
1137  *      until the search has finished. It is _not_ safe against modifications
1138  *      from other threads.
1139  *
1140  * Results:
1141  *      Updates the variables pointed to by keyPtrPtr, valuePtrPtr and
1142  *      donePtr. Either of keyPtrPtr and valuePtrPtr may be NULL, in which
1143  *      case the key/value is not made available to the caller.
1144  *
1145  * Side effects:
1146  *      Removes a reference to the dictionary's internal rep if the search
1147  *      terminates.
1148  *
1149  *----------------------------------------------------------------------
1150  */
1151
1152 void
1153 Tcl_DictObjNext(
1154     Tcl_DictSearch *searchPtr,  /* Pointer to a hash search context. */
1155     Tcl_Obj **keyPtrPtr,        /* Pointer to a variable to have the first key
1156                                  * written into, or NULL. */
1157     Tcl_Obj **valuePtrPtr,      /* Pointer to a variable to have the first
1158                                  * value written into, or NULL.*/
1159     int *donePtr)               /* Pointer to a variable which will have a 1
1160                                  * written into when there are no further
1161                                  * values in the dictionary, or a 0
1162                                  * otherwise. */
1163 {
1164     ChainEntry *cPtr;
1165
1166     /*
1167      * If the searh is done; we do no work.
1168      */
1169
1170     if (searchPtr->epoch == -1) {
1171         *donePtr = 1;
1172         return;
1173     }
1174
1175     /*
1176      * Bail out if the dictionary has had any elements added, modified or
1177      * removed. This *shouldn't* happen, but...
1178      */
1179
1180     if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) {
1181         Tcl_Panic("concurrent dictionary modification and search");
1182     }
1183
1184     cPtr = searchPtr->next;
1185     if (cPtr == NULL) {
1186         Tcl_DictObjDone(searchPtr);
1187         *donePtr = 1;
1188         return;
1189     }
1190
1191     searchPtr->next = cPtr->nextPtr;
1192     *donePtr = 0;
1193     if (keyPtrPtr != NULL) {
1194         *keyPtrPtr = Tcl_GetHashKey(
1195                 &((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry);
1196     }
1197     if (valuePtrPtr != NULL) {
1198         *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry);
1199     }
1200 }
1201 \f
1202 /*
1203  *----------------------------------------------------------------------
1204  *
1205  * Tcl_DictObjDone --
1206  *
1207  *      Call this if you want to stop a search before you reach the end of the
1208  *      dictionary (e.g. because of abnormal termination of the search). It
1209  *      need not be used if the search reaches its natural end (i.e. if either
1210  *      Tcl_DictObjFirst or Tcl_DictObjNext sets its donePtr variable to 1).
1211  *
1212  * Results:
1213  *      None.
1214  *
1215  * Side effects:
1216  *      Removes a reference to the dictionary's internal rep.
1217  *
1218  *----------------------------------------------------------------------
1219  */
1220
1221 void
1222 Tcl_DictObjDone(
1223     Tcl_DictSearch *searchPtr)          /* Pointer to a hash search context. */
1224 {
1225     Dict *dict;
1226
1227     if (searchPtr->epoch != -1) {
1228         searchPtr->epoch = -1;
1229         dict = (Dict *) searchPtr->dictionaryPtr;
1230         if (dict->refCount-- <= 1) {
1231             DeleteDict(dict);
1232         }
1233     }
1234 }
1235 \f
1236 /*
1237  *----------------------------------------------------------------------
1238  *
1239  * Tcl_DictObjPutKeyList --
1240  *
1241  *      Add a key...key,value pair to a dictionary tree. The main dictionary
1242  *      value must not be shared, though sub-dictionaries may be. All
1243  *      intermediate dictionaries on the path must exist.
1244  *
1245  * Results:
1246  *      A standard Tcl result. Note that in the error case, a message is left
1247  *      in interp unless that is NULL.
1248  *
1249  * Side effects:
1250  *      If the dictionary and any of its sub-dictionaries on the path have
1251  *      string representations, these are invalidated.
1252  *
1253  *----------------------------------------------------------------------
1254  */
1255
1256 int
1257 Tcl_DictObjPutKeyList(
1258     Tcl_Interp *interp,
1259     Tcl_Obj *dictPtr,
1260     int keyc,
1261     Tcl_Obj *const keyv[],
1262     Tcl_Obj *valuePtr)
1263 {
1264     Dict *dict;
1265     Tcl_HashEntry *hPtr;
1266     int isNew;
1267
1268     if (Tcl_IsShared(dictPtr)) {
1269         Tcl_Panic("%s called with shared object", "Tcl_DictObjPutKeyList");
1270     }
1271     if (keyc < 1) {
1272         Tcl_Panic("%s called with empty key list", "Tcl_DictObjPutKeyList");
1273     }
1274
1275     dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_CREATE);
1276     if (dictPtr == NULL) {
1277         return TCL_ERROR;
1278     }
1279
1280     dict = DICT(dictPtr);
1281     hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
1282     Tcl_IncrRefCount(valuePtr);
1283     if (!isNew) {
1284         Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
1285
1286         TclDecrRefCount(oldValuePtr);
1287     }
1288     Tcl_SetHashValue(hPtr, valuePtr);
1289     InvalidateDictChain(dictPtr);
1290
1291     return TCL_OK;
1292 }
1293 \f
1294 /*
1295  *----------------------------------------------------------------------
1296  *
1297  * Tcl_DictObjRemoveKeyList --
1298  *
1299  *      Remove a key...key,value pair from a dictionary tree (the value
1300  *      removed is implicit in the key path). The main dictionary value must
1301  *      not be shared, though sub-dictionaries may be. It is not an error if
1302  *      there is no value associated with the given key list, but all
1303  *      intermediate dictionaries on the key path must exist.
1304  *
1305  * Results:
1306  *      A standard Tcl result. Note that in the error case, a message is left
1307  *      in interp unless that is NULL.
1308  *
1309  * Side effects:
1310  *      If the dictionary and any of its sub-dictionaries on the key path have
1311  *      string representations, these are invalidated.
1312  *
1313  *----------------------------------------------------------------------
1314  */
1315
1316 int
1317 Tcl_DictObjRemoveKeyList(
1318     Tcl_Interp *interp,
1319     Tcl_Obj *dictPtr,
1320     int keyc,
1321     Tcl_Obj *const keyv[])
1322 {
1323     Dict *dict;
1324
1325     if (Tcl_IsShared(dictPtr)) {
1326         Tcl_Panic("%s called with shared object", "Tcl_DictObjRemoveKeyList");
1327     }
1328     if (keyc < 1) {
1329         Tcl_Panic("%s called with empty key list", "Tcl_DictObjRemoveKeyList");
1330     }
1331
1332     dictPtr = TclTraceDictPath(interp, dictPtr, keyc-1,keyv, DICT_PATH_UPDATE);
1333     if (dictPtr == NULL) {
1334         return TCL_ERROR;
1335     }
1336
1337     dict = DICT(dictPtr);
1338     DeleteChainEntry(dict, keyv[keyc-1]);
1339     InvalidateDictChain(dictPtr);
1340     return TCL_OK;
1341 }
1342 \f
1343 /*
1344  *----------------------------------------------------------------------
1345  *
1346  * Tcl_NewDictObj --
1347  *
1348  *      This function is normally called when not debugging: i.e., when
1349  *      TCL_MEM_DEBUG is not defined. It creates a new dict object without any
1350  *      content.
1351  *
1352  *      When TCL_MEM_DEBUG is defined, this function just returns the result
1353  *      of calling the debugging version Tcl_DbNewDictObj.
1354  *
1355  * Results:
1356  *      A new dict object is returned; it has no keys defined in it. The new
1357  *      object's string representation is left NULL, and the ref count of the
1358  *      object is 0.
1359  *
1360  * Side Effects:
1361  *      None.
1362  *
1363  *----------------------------------------------------------------------
1364  */
1365
1366 Tcl_Obj *
1367 Tcl_NewDictObj(void)
1368 {
1369 #ifdef TCL_MEM_DEBUG
1370     return Tcl_DbNewDictObj("unknown", 0);
1371 #else /* !TCL_MEM_DEBUG */
1372
1373     Tcl_Obj *dictPtr;
1374     Dict *dict;
1375
1376     TclNewObj(dictPtr);
1377     TclInvalidateStringRep(dictPtr);
1378     dict = ckalloc(sizeof(Dict));
1379     InitChainTable(dict);
1380     dict->epoch = 0;
1381     dict->chain = NULL;
1382     dict->refCount = 1;
1383     DICT(dictPtr) = dict;
1384     dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
1385     dictPtr->typePtr = &tclDictType;
1386     return dictPtr;
1387 #endif
1388 }
1389 \f
1390 /*
1391  *----------------------------------------------------------------------
1392  *
1393  * Tcl_DbNewDictObj --
1394  *
1395  *      This function is normally called when debugging: i.e., when
1396  *      TCL_MEM_DEBUG is defined. It creates new dict objects. It is the same
1397  *      as the Tcl_NewDictObj function above except that it calls
1398  *      Tcl_DbCkalloc directly with the file name and line number from its
1399  *      caller. This simplifies debugging since then the [memory active]
1400  *      command will report the correct file name and line number when
1401  *      reporting objects that haven't been freed.
1402  *
1403  *      When TCL_MEM_DEBUG is not defined, this function just returns the
1404  *      result of calling Tcl_NewDictObj.
1405  *
1406  * Results:
1407  *      A new dict object is returned; it has no keys defined in it. The new
1408  *      object's string representation is left NULL, and the ref count of the
1409  *      object is 0.
1410  *
1411  * Side Effects:
1412  *      None.
1413  *
1414  *----------------------------------------------------------------------
1415  */
1416
1417 Tcl_Obj *
1418 Tcl_DbNewDictObj(
1419     const char *file,
1420     int line)
1421 {
1422 #ifdef TCL_MEM_DEBUG
1423     Tcl_Obj *dictPtr;
1424     Dict *dict;
1425
1426     TclDbNewObj(dictPtr, file, line);
1427     TclInvalidateStringRep(dictPtr);
1428     dict = ckalloc(sizeof(Dict));
1429     InitChainTable(dict);
1430     dict->epoch = 0;
1431     dict->chain = NULL;
1432     dict->refCount = 1;
1433     DICT(dictPtr) = dict;
1434     dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
1435     dictPtr->typePtr = &tclDictType;
1436     return dictPtr;
1437 #else /* !TCL_MEM_DEBUG */
1438     return Tcl_NewDictObj();
1439 #endif
1440 }
1441 \f
1442 /***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
1443
1444 /*
1445  *----------------------------------------------------------------------
1446  *
1447  * DictCreateCmd --
1448  *
1449  *      This function implements the "dict create" Tcl command. See the user
1450  *      documentation for details on what it does, and TIP#111 for the formal
1451  *      specification.
1452  *
1453  * Results:
1454  *      A standard Tcl result.
1455  *
1456  * Side effects:
1457  *      See the user documentation.
1458  *
1459  *----------------------------------------------------------------------
1460  */
1461
1462 static int
1463 DictCreateCmd(
1464     ClientData dummy,
1465     Tcl_Interp *interp,
1466     int objc,
1467     Tcl_Obj *const *objv)
1468 {
1469     Tcl_Obj *dictObj;
1470     int i;
1471
1472     /*
1473      * Must have an even number of arguments; note that number of preceding
1474      * arguments (i.e. "dict create" is also even, which makes this much
1475      * easier.)
1476      */
1477
1478     if ((objc & 1) == 0) {
1479         Tcl_WrongNumArgs(interp, 1, objv, "?key value ...?");
1480         return TCL_ERROR;
1481     }
1482
1483     dictObj = Tcl_NewDictObj();
1484     for (i=1 ; i<objc ; i+=2) {
1485         /*
1486          * The next command is assumed to never fail...
1487          */
1488         Tcl_DictObjPut(NULL, dictObj, objv[i], objv[i+1]);
1489     }
1490     Tcl_SetObjResult(interp, dictObj);
1491     return TCL_OK;
1492 }
1493 \f
1494 /*
1495  *----------------------------------------------------------------------
1496  *
1497  * DictGetCmd --
1498  *
1499  *      This function implements the "dict get" Tcl command. See the user
1500  *      documentation for details on what it does, and TIP#111 for the formal
1501  *      specification.
1502  *
1503  * Results:
1504  *      A standard Tcl result.
1505  *
1506  * Side effects:
1507  *      See the user documentation.
1508  *
1509  *----------------------------------------------------------------------
1510  */
1511
1512 static int
1513 DictGetCmd(
1514     ClientData dummy,
1515     Tcl_Interp *interp,
1516     int objc,
1517     Tcl_Obj *const *objv)
1518 {
1519     Tcl_Obj *dictPtr, *valuePtr = NULL;
1520     int result;
1521
1522     if (objc < 2) {
1523         Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
1524         return TCL_ERROR;
1525     }
1526
1527     /*
1528      * Test for the special case of no keys, which returns a *list* of all
1529      * key,value pairs. We produce a copy here because that makes subsequent
1530      * list handling more efficient.
1531      */
1532
1533     if (objc == 2) {
1534         Tcl_Obj *keyPtr = NULL, *listPtr;
1535         Tcl_DictSearch search;
1536         int done;
1537
1538         result = Tcl_DictObjFirst(interp, objv[1], &search,
1539                 &keyPtr, &valuePtr, &done);
1540         if (result != TCL_OK) {
1541             return result;
1542         }
1543         listPtr = Tcl_NewListObj(0, NULL);
1544         while (!done) {
1545             /*
1546              * Assume these won't fail as we have complete control over the
1547              * types of things here.
1548              */
1549
1550             Tcl_ListObjAppendElement(interp, listPtr, keyPtr);
1551             Tcl_ListObjAppendElement(interp, listPtr, valuePtr);
1552
1553             Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
1554         }
1555         Tcl_SetObjResult(interp, listPtr);
1556         return TCL_OK;
1557     }
1558
1559     /*
1560      * Loop through the list of keys, looking up the key at the current index
1561      * in the current dictionary each time. Once we've done the lookup, we set
1562      * the current dictionary to be the value we looked up (in case the value
1563      * was not the last one and we are going through a chain of searches.)
1564      * Note that this loop always executes at least once.
1565      */
1566
1567     dictPtr = TclTraceDictPath(interp, objv[1], objc-3,objv+2, DICT_PATH_READ);
1568     if (dictPtr == NULL) {
1569         return TCL_ERROR;
1570     }
1571     result = Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr);
1572     if (result != TCL_OK) {
1573         return result;
1574     }
1575     if (valuePtr == NULL) {
1576         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1577                 "key \"%s\" not known in dictionary",
1578                 TclGetString(objv[objc-1])));
1579         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
1580                 TclGetString(objv[objc-1]), NULL);
1581         return TCL_ERROR;
1582     }
1583     Tcl_SetObjResult(interp, valuePtr);
1584     return TCL_OK;
1585 }
1586 \f
1587 /*
1588  *----------------------------------------------------------------------
1589  *
1590  * DictReplaceCmd --
1591  *
1592  *      This function implements the "dict replace" Tcl command. See the user
1593  *      documentation for details on what it does, and TIP#111 for the formal
1594  *      specification.
1595  *
1596  * Results:
1597  *      A standard Tcl result.
1598  *
1599  * Side effects:
1600  *      See the user documentation.
1601  *
1602  *----------------------------------------------------------------------
1603  */
1604
1605 static int
1606 DictReplaceCmd(
1607     ClientData dummy,
1608     Tcl_Interp *interp,
1609     int objc,
1610     Tcl_Obj *const *objv)
1611 {
1612     Tcl_Obj *dictPtr;
1613     int i;
1614
1615     if ((objc < 2) || (objc & 1)) {
1616         Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?");
1617         return TCL_ERROR;
1618     }
1619
1620     dictPtr = objv[1];
1621     if (dictPtr->typePtr != &tclDictType
1622             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
1623         return TCL_ERROR;
1624     }
1625     if (Tcl_IsShared(dictPtr)) {
1626         dictPtr = Tcl_DuplicateObj(dictPtr);
1627     }
1628     if (dictPtr->bytes != NULL) {
1629         TclInvalidateStringRep(dictPtr);
1630     }
1631     for (i=2 ; i<objc ; i+=2) {
1632         Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
1633     }
1634     Tcl_SetObjResult(interp, dictPtr);
1635     return TCL_OK;
1636 }
1637 \f
1638 /*
1639  *----------------------------------------------------------------------
1640  *
1641  * DictRemoveCmd --
1642  *
1643  *      This function implements the "dict remove" Tcl command. See the user
1644  *      documentation for details on what it does, and TIP#111 for the formal
1645  *      specification.
1646  *
1647  * Results:
1648  *      A standard Tcl result.
1649  *
1650  * Side effects:
1651  *      See the user documentation.
1652  *
1653  *----------------------------------------------------------------------
1654  */
1655
1656 static int
1657 DictRemoveCmd(
1658     ClientData dummy,
1659     Tcl_Interp *interp,
1660     int objc,
1661     Tcl_Obj *const *objv)
1662 {
1663     Tcl_Obj *dictPtr;
1664     int i;
1665
1666     if (objc < 2) {
1667         Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
1668         return TCL_ERROR;
1669     }
1670
1671     dictPtr = objv[1];
1672     if (dictPtr->typePtr != &tclDictType
1673             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
1674         return TCL_ERROR;
1675     }
1676     if (Tcl_IsShared(dictPtr)) {
1677         dictPtr = Tcl_DuplicateObj(dictPtr);
1678     }
1679     if (dictPtr->bytes != NULL) {
1680         TclInvalidateStringRep(dictPtr);
1681     }
1682     for (i=2 ; i<objc ; i++) {
1683         Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
1684     }
1685     Tcl_SetObjResult(interp, dictPtr);
1686     return TCL_OK;
1687 }
1688 \f
1689 /*
1690  *----------------------------------------------------------------------
1691  *
1692  * DictMergeCmd --
1693  *
1694  *      This function implements the "dict merge" Tcl command. See the user
1695  *      documentation for details on what it does, and TIP#163 for the formal
1696  *      specification.
1697  *
1698  * Results:
1699  *      A standard Tcl result.
1700  *
1701  * Side effects:
1702  *      See the user documentation.
1703  *
1704  *----------------------------------------------------------------------
1705  */
1706
1707 static int
1708 DictMergeCmd(
1709     ClientData dummy,
1710     Tcl_Interp *interp,
1711     int objc,
1712     Tcl_Obj *const *objv)
1713 {
1714     Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL;
1715     int allocatedDict = 0;
1716     int i, done;
1717     Tcl_DictSearch search;
1718
1719     if (objc == 1) {
1720         /*
1721          * No dictionary arguments; return default (empty value).
1722          */
1723
1724         return TCL_OK;
1725     }
1726
1727     /*
1728      * Make sure first argument is a dictionary.
1729      */
1730
1731     targetObj = objv[1];
1732     if (targetObj->typePtr != &tclDictType
1733             && SetDictFromAny(interp, targetObj) != TCL_OK) {
1734         return TCL_ERROR;
1735     }
1736
1737     if (objc == 2) {
1738         /*
1739          * Single argument, return it.
1740          */
1741
1742         Tcl_SetObjResult(interp, objv[1]);
1743         return TCL_OK;
1744     }
1745
1746     /*
1747      * Normal behaviour: combining two (or more) dictionaries.
1748      */
1749
1750     if (Tcl_IsShared(targetObj)) {
1751         targetObj = Tcl_DuplicateObj(targetObj);
1752         allocatedDict = 1;
1753     }
1754     for (i=2 ; i<objc ; i++) {
1755         if (Tcl_DictObjFirst(interp, objv[i], &search, &keyObj, &valueObj,
1756                 &done) != TCL_OK) {
1757             if (allocatedDict) {
1758                 TclDecrRefCount(targetObj);
1759             }
1760             return TCL_ERROR;
1761         }
1762         while (!done) {
1763             /*
1764              * Next line can't fail; already know we have a dictionary in
1765              * targetObj.
1766              */
1767
1768             Tcl_DictObjPut(NULL, targetObj, keyObj, valueObj);
1769             Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
1770         }
1771         Tcl_DictObjDone(&search);
1772     }
1773     Tcl_SetObjResult(interp, targetObj);
1774     return TCL_OK;
1775 }
1776 \f
1777 /*
1778  *----------------------------------------------------------------------
1779  *
1780  * DictKeysCmd --
1781  *
1782  *      This function implements the "dict keys" Tcl command. See the user
1783  *      documentation for details on what it does, and TIP#111 for the formal
1784  *      specification.
1785  *
1786  * Results:
1787  *      A standard Tcl result.
1788  *
1789  * Side effects:
1790  *      See the user documentation.
1791  *
1792  *----------------------------------------------------------------------
1793  */
1794
1795 static int
1796 DictKeysCmd(
1797     ClientData dummy,
1798     Tcl_Interp *interp,
1799     int objc,
1800     Tcl_Obj *const *objv)
1801 {
1802     Tcl_Obj *listPtr;
1803     const char *pattern = NULL;
1804
1805     if (objc!=2 && objc!=3) {
1806         Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?");
1807         return TCL_ERROR;
1808     }
1809
1810     /*
1811      * A direct check that we have a dictionary. We don't start the iteration
1812      * yet because that might allocate memory or set locks that we do not
1813      * need. [Bug 1705778, leak K04]
1814      */
1815
1816     if (objv[1]->typePtr != &tclDictType
1817             && SetDictFromAny(interp, objv[1]) != TCL_OK) {
1818         return TCL_ERROR;
1819     }
1820
1821     if (objc == 3) {
1822         pattern = TclGetString(objv[2]);
1823     }
1824     listPtr = Tcl_NewListObj(0, NULL);
1825     if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
1826         Tcl_Obj *valuePtr = NULL;
1827
1828         Tcl_DictObjGet(interp, objv[1], objv[2], &valuePtr);
1829         if (valuePtr != NULL) {
1830             Tcl_ListObjAppendElement(NULL, listPtr, objv[2]);
1831         }
1832     } else {
1833         Tcl_DictSearch search;
1834         Tcl_Obj *keyPtr = NULL;
1835         int done = 0;
1836
1837         /*
1838          * At this point, we know we have a dictionary (or at least something
1839          * that can be represented; it could theoretically have shimmered away
1840          * when the pattern was fetched, but that shouldn't be damaging) so we
1841          * can start the iteration process without checking for failures.
1842          */
1843
1844         Tcl_DictObjFirst(NULL, objv[1], &search, &keyPtr, NULL, &done);
1845         for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) {
1846             if (!pattern || Tcl_StringMatch(TclGetString(keyPtr), pattern)) {
1847                 Tcl_ListObjAppendElement(NULL, listPtr, keyPtr);
1848             }
1849         }
1850         Tcl_DictObjDone(&search);
1851     }
1852
1853     Tcl_SetObjResult(interp, listPtr);
1854     return TCL_OK;
1855 }
1856 \f
1857 /*
1858  *----------------------------------------------------------------------
1859  *
1860  * DictValuesCmd --
1861  *
1862  *      This function implements the "dict values" Tcl command. See the user
1863  *      documentation for details on what it does, and TIP#111 for the formal
1864  *      specification.
1865  *
1866  * Results:
1867  *      A standard Tcl result.
1868  *
1869  * Side effects:
1870  *      See the user documentation.
1871  *
1872  *----------------------------------------------------------------------
1873  */
1874
1875 static int
1876 DictValuesCmd(
1877     ClientData dummy,
1878     Tcl_Interp *interp,
1879     int objc,
1880     Tcl_Obj *const *objv)
1881 {
1882     Tcl_Obj *valuePtr = NULL, *listPtr;
1883     Tcl_DictSearch search;
1884     int done;
1885     const char *pattern;
1886
1887     if (objc!=2 && objc!=3) {
1888         Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?pattern?");
1889         return TCL_ERROR;
1890     }
1891
1892     if (Tcl_DictObjFirst(interp, objv[1], &search, NULL, &valuePtr,
1893             &done) != TCL_OK) {
1894         return TCL_ERROR;
1895     }
1896     if (objc == 3) {
1897         pattern = TclGetString(objv[2]);
1898     } else {
1899         pattern = NULL;
1900     }
1901     listPtr = Tcl_NewListObj(0, NULL);
1902     for (; !done ; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
1903         if (pattern==NULL || Tcl_StringMatch(TclGetString(valuePtr),pattern)) {
1904             /*
1905              * Assume this operation always succeeds.
1906              */
1907
1908             Tcl_ListObjAppendElement(interp, listPtr, valuePtr);
1909         }
1910     }
1911     Tcl_DictObjDone(&search);
1912
1913     Tcl_SetObjResult(interp, listPtr);
1914     return TCL_OK;
1915 }
1916 \f
1917 /*
1918  *----------------------------------------------------------------------
1919  *
1920  * DictSizeCmd --
1921  *
1922  *      This function implements the "dict size" Tcl command. See the user
1923  *      documentation for details on what it does, and TIP#111 for the formal
1924  *      specification.
1925  *
1926  * Results:
1927  *      A standard Tcl result.
1928  *
1929  * Side effects:
1930  *      See the user documentation.
1931  *
1932  *----------------------------------------------------------------------
1933  */
1934
1935 static int
1936 DictSizeCmd(
1937     ClientData dummy,
1938     Tcl_Interp *interp,
1939     int objc,
1940     Tcl_Obj *const *objv)
1941 {
1942     int result, size;
1943
1944     if (objc != 2) {
1945         Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
1946         return TCL_ERROR;
1947     }
1948     result = Tcl_DictObjSize(interp, objv[1], &size);
1949     if (result == TCL_OK) {
1950         Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
1951     }
1952     return result;
1953 }
1954 \f
1955 /*
1956  *----------------------------------------------------------------------
1957  *
1958  * DictExistsCmd --
1959  *
1960  *      This function implements the "dict exists" Tcl command. See the user
1961  *      documentation for details on what it does, and TIP#111 for the formal
1962  *      specification.
1963  *
1964  * Results:
1965  *      A standard Tcl result.
1966  *
1967  * Side effects:
1968  *      See the user documentation.
1969  *
1970  *----------------------------------------------------------------------
1971  */
1972
1973 static int
1974 DictExistsCmd(
1975     ClientData dummy,
1976     Tcl_Interp *interp,
1977     int objc,
1978     Tcl_Obj *const *objv)
1979 {
1980     Tcl_Obj *dictPtr, *valuePtr;
1981
1982     if (objc < 3) {
1983         Tcl_WrongNumArgs(interp, 1, objv, "dictionary key ?key ...?");
1984         return TCL_ERROR;
1985     }
1986
1987     dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2,
1988             DICT_PATH_EXISTS);
1989     if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT
1990             || Tcl_DictObjGet(interp, dictPtr, objv[objc-1],
1991                     &valuePtr) != TCL_OK) {
1992         Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
1993     } else {
1994         Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL));
1995     }
1996     return TCL_OK;
1997 }
1998 \f
1999 /*
2000  *----------------------------------------------------------------------
2001  *
2002  * DictInfoCmd --
2003  *
2004  *      This function implements the "dict info" Tcl command. See the user
2005  *      documentation for details on what it does, and TIP#111 for the formal
2006  *      specification.
2007  *
2008  * Results:
2009  *      A standard Tcl result.
2010  *
2011  * Side effects:
2012  *      See the user documentation.
2013  *
2014  *----------------------------------------------------------------------
2015  */
2016
2017 static int
2018 DictInfoCmd(
2019     ClientData dummy,
2020     Tcl_Interp *interp,
2021     int objc,
2022     Tcl_Obj *const *objv)
2023 {
2024     Tcl_Obj *dictPtr;
2025     Dict *dict;
2026     char *statsStr;
2027
2028     if (objc != 2) {
2029         Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
2030         return TCL_ERROR;
2031     }
2032
2033     dictPtr = objv[1];
2034     if (dictPtr->typePtr != &tclDictType
2035             && SetDictFromAny(interp, dictPtr) != TCL_OK) {
2036         return TCL_ERROR;
2037     }
2038     dict = DICT(dictPtr);
2039
2040     statsStr = Tcl_HashStats(&dict->table);
2041     Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
2042     ckfree(statsStr);
2043     return TCL_OK;
2044 }
2045 \f
2046 /*
2047  *----------------------------------------------------------------------
2048  *
2049  * DictIncrCmd --
2050  *
2051  *      This function implements the "dict incr" Tcl command. See the user
2052  *      documentation for details on what it does, and TIP#111 for the formal
2053  *      specification.
2054  *
2055  * Results:
2056  *      A standard Tcl result.
2057  *
2058  * Side effects:
2059  *      See the user documentation.
2060  *
2061  *----------------------------------------------------------------------
2062  */
2063
2064 static int
2065 DictIncrCmd(
2066     ClientData dummy,
2067     Tcl_Interp *interp,
2068     int objc,
2069     Tcl_Obj *const *objv)
2070 {
2071     int code = TCL_OK;
2072     Tcl_Obj *dictPtr, *valuePtr = NULL;
2073
2074     if (objc < 3 || objc > 4) {
2075         Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?increment?");
2076         return TCL_ERROR;
2077     }
2078
2079     dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
2080     if (dictPtr == NULL) {
2081         /*
2082          * Variable didn't yet exist. Create new dictionary value.
2083          */
2084
2085         dictPtr = Tcl_NewDictObj();
2086     } else if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) {
2087         /*
2088          * Variable contents are not a dict, report error.
2089          */
2090
2091         return TCL_ERROR;
2092     }
2093     if (Tcl_IsShared(dictPtr)) {
2094         /*
2095          * A little internals surgery to avoid copying a string rep that will
2096          * soon be no good.
2097          */
2098
2099         char *saved = dictPtr->bytes;
2100         Tcl_Obj *oldPtr = dictPtr;
2101
2102         dictPtr->bytes = NULL;
2103         dictPtr = Tcl_DuplicateObj(dictPtr);
2104         oldPtr->bytes = saved;
2105     }
2106     if (valuePtr == NULL) {
2107         /*
2108          * Key not in dictionary. Create new key with increment as value.
2109          */
2110
2111         if (objc == 4) {
2112             /*
2113              * Verify increment is an integer.
2114              */
2115
2116             mp_int increment;
2117
2118             code = Tcl_GetBignumFromObj(interp, objv[3], &increment);
2119             if (code != TCL_OK) {
2120                 Tcl_AddErrorInfo(interp, "\n    (reading increment)");
2121             } else {
2122                 /*
2123                  * Remember to dispose with the bignum as we're not actually
2124                  * using it directly. [Bug 2874678]
2125                  */
2126
2127                 mp_clear(&increment);
2128                 Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
2129             }
2130         } else {
2131             Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1));
2132         }
2133     } else {
2134         /*
2135          * Key in dictionary. Increment its value with minimum dup.
2136          */
2137
2138         if (Tcl_IsShared(valuePtr)) {
2139             valuePtr = Tcl_DuplicateObj(valuePtr);
2140             Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
2141         }
2142         if (objc == 4) {
2143             code = TclIncrObj(interp, valuePtr, objv[3]);
2144         } else {
2145             Tcl_Obj *incrPtr;
2146
2147             TclNewIntObj(incrPtr, 1);
2148             Tcl_IncrRefCount(incrPtr);
2149             code = TclIncrObj(interp, valuePtr, incrPtr);
2150             TclDecrRefCount(incrPtr);
2151         }
2152     }
2153     if (code == TCL_OK) {
2154         TclInvalidateStringRep(dictPtr);
2155         valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
2156                 dictPtr, TCL_LEAVE_ERR_MSG);
2157         if (valuePtr == NULL) {
2158             code = TCL_ERROR;
2159         } else {
2160             Tcl_SetObjResult(interp, valuePtr);
2161         }
2162     } else if (dictPtr->refCount == 0) {
2163         TclDecrRefCount(dictPtr);
2164     }
2165     return code;
2166 }
2167 \f
2168 /*
2169  *----------------------------------------------------------------------
2170  *
2171  * DictLappendCmd --
2172  *
2173  *      This function implements the "dict lappend" Tcl command. See the user
2174  *      documentation for details on what it does, and TIP#111 for the formal
2175  *      specification.
2176  *
2177  * Results:
2178  *      A standard Tcl result.
2179  *
2180  * Side effects:
2181  *      See the user documentation.
2182  *
2183  *----------------------------------------------------------------------
2184  */
2185
2186 static int
2187 DictLappendCmd(
2188     ClientData dummy,
2189     Tcl_Interp *interp,
2190     int objc,
2191     Tcl_Obj *const *objv)
2192 {
2193     Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
2194     int i, allocatedDict = 0, allocatedValue = 0;
2195
2196     if (objc < 3) {
2197         Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
2198         return TCL_ERROR;
2199     }
2200
2201     dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
2202     if (dictPtr == NULL) {
2203         allocatedDict = 1;
2204         dictPtr = Tcl_NewDictObj();
2205     } else if (Tcl_IsShared(dictPtr)) {
2206         allocatedDict = 1;
2207         dictPtr = Tcl_DuplicateObj(dictPtr);
2208     }
2209
2210     if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) {
2211         if (allocatedDict) {
2212             TclDecrRefCount(dictPtr);
2213         }
2214         return TCL_ERROR;
2215     }
2216
2217     if (valuePtr == NULL) {
2218         valuePtr = Tcl_NewListObj(objc-3, objv+3);
2219         allocatedValue = 1;
2220     } else {
2221         if (Tcl_IsShared(valuePtr)) {
2222             allocatedValue = 1;
2223             valuePtr = Tcl_DuplicateObj(valuePtr);
2224         }
2225
2226         for (i=3 ; i<objc ; i++) {
2227             if (Tcl_ListObjAppendElement(interp, valuePtr,
2228                     objv[i]) != TCL_OK) {
2229                 if (allocatedValue) {
2230                     TclDecrRefCount(valuePtr);
2231                 }
2232                 if (allocatedDict) {
2233                     TclDecrRefCount(dictPtr);
2234                 }
2235                 return TCL_ERROR;
2236             }
2237         }
2238     }
2239
2240     if (allocatedValue) {
2241         Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
2242     } else if (dictPtr->bytes != NULL) {
2243         TclInvalidateStringRep(dictPtr);
2244     }
2245
2246     resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
2247             TCL_LEAVE_ERR_MSG);
2248     if (resultPtr == NULL) {
2249         return TCL_ERROR;
2250     }
2251     Tcl_SetObjResult(interp, resultPtr);
2252     return TCL_OK;
2253 }
2254 \f
2255 /*
2256  *----------------------------------------------------------------------
2257  *
2258  * DictAppendCmd --
2259  *
2260  *      This function implements the "dict append" Tcl command. See the user
2261  *      documentation for details on what it does, and TIP#111 for the formal
2262  *      specification.
2263  *
2264  * Results:
2265  *      A standard Tcl result.
2266  *
2267  * Side effects:
2268  *      See the user documentation.
2269  *
2270  *----------------------------------------------------------------------
2271  */
2272
2273 static int
2274 DictAppendCmd(
2275     ClientData dummy,
2276     Tcl_Interp *interp,
2277     int objc,
2278     Tcl_Obj *const *objv)
2279 {
2280     Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
2281     int i, allocatedDict = 0;
2282
2283     if (objc < 3) {
2284         Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
2285         return TCL_ERROR;
2286     }
2287
2288     dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
2289     if (dictPtr == NULL) {
2290         allocatedDict = 1;
2291         dictPtr = Tcl_NewDictObj();
2292     } else if (Tcl_IsShared(dictPtr)) {
2293         allocatedDict = 1;
2294         dictPtr = Tcl_DuplicateObj(dictPtr);
2295     }
2296
2297     if (Tcl_DictObjGet(interp, dictPtr, objv[2], &valuePtr) != TCL_OK) {
2298         if (allocatedDict) {
2299             TclDecrRefCount(dictPtr);
2300         }
2301         return TCL_ERROR;
2302     }
2303
2304     if (valuePtr == NULL) {
2305         TclNewObj(valuePtr);
2306     } else if (Tcl_IsShared(valuePtr)) {
2307         valuePtr = Tcl_DuplicateObj(valuePtr);
2308     }
2309
2310     for (i=3 ; i<objc ; i++) {
2311         Tcl_AppendObjToObj(valuePtr, objv[i]);
2312     }
2313
2314     Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
2315
2316     resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
2317             TCL_LEAVE_ERR_MSG);
2318     if (resultPtr == NULL) {
2319         return TCL_ERROR;
2320     }
2321     Tcl_SetObjResult(interp, resultPtr);
2322     return TCL_OK;
2323 }
2324 \f
2325 /*
2326  *----------------------------------------------------------------------
2327  *
2328  * DictForNRCmd --
2329  *
2330  *      These functions implement the "dict for" Tcl command.  See the user
2331  *      documentation for details on what it does, and TIP#111 for the formal
2332  *      specification.
2333  *
2334  * Results:
2335  *      A standard Tcl result.
2336  *
2337  * Side effects:
2338  *      See the user documentation.
2339  *
2340  *----------------------------------------------------------------------
2341  */
2342
2343 static int
2344 DictForNRCmd(
2345     ClientData dummy,
2346     Tcl_Interp *interp,
2347     int objc,
2348     Tcl_Obj *const *objv)
2349 {
2350     Interp *iPtr = (Interp *) interp;
2351     Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
2352     Tcl_Obj **varv, *keyObj, *valueObj;
2353     Tcl_DictSearch *searchPtr;
2354     int varc, done;
2355
2356     if (objc != 4) {
2357         Tcl_WrongNumArgs(interp, 1, objv,
2358                 "{keyVarName valueVarName} dictionary script");
2359         return TCL_ERROR;
2360     }
2361
2362     /*
2363      * Parse arguments.
2364      */
2365
2366     if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
2367         return TCL_ERROR;
2368     }
2369     if (varc != 2) {
2370         Tcl_SetObjResult(interp, Tcl_NewStringObj(
2371                 "must have exactly two variable names", -1));
2372         Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
2373         return TCL_ERROR;
2374     }
2375     searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
2376     if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
2377             &done) != TCL_OK) {
2378         TclStackFree(interp, searchPtr);
2379         return TCL_ERROR;
2380     }
2381     if (done) {
2382         TclStackFree(interp, searchPtr);
2383         return TCL_OK;
2384     }
2385     TclListObjGetElements(NULL, objv[1], &varc, &varv);
2386     keyVarObj = varv[0];
2387     valueVarObj = varv[1];
2388     scriptObj = objv[3];
2389
2390     /*
2391      * Make sure that these objects (which we need throughout the body of the
2392      * loop) don't vanish. Note that the dictionary internal rep is locked
2393      * internally so that updates, shimmering, etc are not a problem.
2394      */
2395
2396     Tcl_IncrRefCount(keyVarObj);
2397     Tcl_IncrRefCount(valueVarObj);
2398     Tcl_IncrRefCount(scriptObj);
2399
2400     /*
2401      * Stop the value from getting hit in any way by any traces on the key
2402      * variable.
2403      */
2404
2405     Tcl_IncrRefCount(valueObj);
2406     if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
2407             TCL_LEAVE_ERR_MSG) == NULL) {
2408         TclDecrRefCount(valueObj);
2409         goto error;
2410     }
2411     TclDecrRefCount(valueObj);
2412     if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
2413             TCL_LEAVE_ERR_MSG) == NULL) {
2414         goto error;
2415     }
2416
2417     /*
2418      * Run the script.
2419      */
2420
2421     TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
2422             valueVarObj, scriptObj);
2423     return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
2424
2425     /*
2426      * For unwinding everything on error.
2427      */
2428
2429   error:
2430     TclDecrRefCount(keyVarObj);
2431     TclDecrRefCount(valueVarObj);
2432     TclDecrRefCount(scriptObj);
2433     Tcl_DictObjDone(searchPtr);
2434     TclStackFree(interp, searchPtr);
2435     return TCL_ERROR;
2436 }
2437
2438 static int
2439 DictForLoopCallback(
2440     ClientData data[],
2441     Tcl_Interp *interp,
2442     int result)
2443 {
2444     Interp *iPtr = (Interp *) interp;
2445     Tcl_DictSearch *searchPtr = data[0];
2446     Tcl_Obj *keyVarObj = data[1];
2447     Tcl_Obj *valueVarObj = data[2];
2448     Tcl_Obj *scriptObj = data[3];
2449     Tcl_Obj *keyObj, *valueObj;
2450     int done;
2451
2452     /*
2453      * Process the result from the previous execution of the script body.
2454      */
2455
2456     if (result == TCL_CONTINUE) {
2457         result = TCL_OK;
2458     } else if (result != TCL_OK) {
2459         if (result == TCL_BREAK) {
2460             Tcl_ResetResult(interp);
2461             result = TCL_OK;
2462         } else if (result == TCL_ERROR) {
2463             Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
2464                     "\n    (\"dict for\" body line %d)",
2465                     Tcl_GetErrorLine(interp)));
2466         }
2467         goto done;
2468     }
2469
2470     /*
2471      * Get the next mapping from the dictionary.
2472      */
2473
2474     Tcl_DictObjNext(searchPtr, &keyObj, &valueObj, &done);
2475     if (done) {
2476         Tcl_ResetResult(interp);
2477         goto done;
2478     }
2479
2480     /*
2481      * Stop the value from getting hit in any way by any traces on the key
2482      * variable.
2483      */
2484
2485     Tcl_IncrRefCount(valueObj);
2486     if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
2487             TCL_LEAVE_ERR_MSG) == NULL) {
2488         TclDecrRefCount(valueObj);
2489         result = TCL_ERROR;
2490         goto done;
2491     }
2492     TclDecrRefCount(valueObj);
2493     if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
2494             TCL_LEAVE_ERR_MSG) == NULL) {
2495         result = TCL_ERROR;
2496         goto done;
2497     }
2498
2499     /*
2500      * Run the script.
2501      */
2502
2503     TclNRAddCallback(interp, DictForLoopCallback, searchPtr, keyVarObj,
2504             valueVarObj, scriptObj);
2505     return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
2506
2507     /*
2508      * For unwinding everything once the iterating is done.
2509      */
2510
2511   done:
2512     TclDecrRefCount(keyVarObj);
2513     TclDecrRefCount(valueVarObj);
2514     TclDecrRefCount(scriptObj);
2515     Tcl_DictObjDone(searchPtr);
2516     TclStackFree(interp, searchPtr);
2517     return result;
2518 }
2519 \f
2520 /*
2521  *----------------------------------------------------------------------
2522  *
2523  * DictMapNRCmd --
2524  *
2525  *      These functions implement the "dict map" Tcl command.  See the user
2526  *      documentation for details on what it does, and TIP#405 for the formal
2527  *      specification.
2528  *
2529  * Results:
2530  *      A standard Tcl result.
2531  *
2532  * Side effects:
2533  *      See the user documentation.
2534  *
2535  *----------------------------------------------------------------------
2536  */
2537
2538 static int
2539 DictMapNRCmd(
2540     ClientData dummy,
2541     Tcl_Interp *interp,
2542     int objc,
2543     Tcl_Obj *const *objv)
2544 {
2545     Interp *iPtr = (Interp *) interp;
2546     Tcl_Obj **varv, *keyObj, *valueObj;
2547     DictMapStorage *storagePtr;
2548     int varc, done;
2549
2550     if (objc != 4) {
2551         Tcl_WrongNumArgs(interp, 1, objv,
2552                 "{keyVarName valueVarName} dictionary script");
2553         return TCL_ERROR;
2554     }
2555
2556     /*
2557      * Parse arguments.
2558      */
2559
2560     if (TclListObjGetElements(interp, objv[1], &varc, &varv) != TCL_OK) {
2561         return TCL_ERROR;
2562     }
2563     if (varc != 2) {
2564         Tcl_SetObjResult(interp, Tcl_NewStringObj(
2565                 "must have exactly two variable names", -1));
2566         Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
2567         return TCL_ERROR;
2568     }
2569     storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
2570     if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
2571             &valueObj, &done) != TCL_OK) {
2572         TclStackFree(interp, storagePtr);
2573         return TCL_ERROR;
2574     }
2575     if (done) {
2576         /*
2577          * Note that this exit leaves an empty value in the result (due to
2578          * command calling conventions) but that is OK since an empty value is
2579          * an empty dictionary.
2580          */
2581
2582         TclStackFree(interp, storagePtr);
2583         return TCL_OK;
2584     }
2585     TclNewObj(storagePtr->accumulatorObj);
2586     TclListObjGetElements(NULL, objv[1], &varc, &varv);
2587     storagePtr->keyVarObj = varv[0];
2588     storagePtr->valueVarObj = varv[1];
2589     storagePtr->scriptObj = objv[3];
2590
2591     /*
2592      * Make sure that these objects (which we need throughout the body of the
2593      * loop) don't vanish. Note that the dictionary internal rep is locked
2594      * internally so that updates, shimmering, etc are not a problem.
2595      */
2596
2597     Tcl_IncrRefCount(storagePtr->accumulatorObj);
2598     Tcl_IncrRefCount(storagePtr->keyVarObj);
2599     Tcl_IncrRefCount(storagePtr->valueVarObj);
2600     Tcl_IncrRefCount(storagePtr->scriptObj);
2601
2602     /*
2603      * Stop the value from getting hit in any way by any traces on the key
2604      * variable.
2605      */
2606
2607     Tcl_IncrRefCount(valueObj);
2608     if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
2609             TCL_LEAVE_ERR_MSG) == NULL) {
2610         TclDecrRefCount(valueObj);
2611         goto error;
2612     }
2613     if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
2614             TCL_LEAVE_ERR_MSG) == NULL) {
2615         TclDecrRefCount(valueObj);
2616         goto error;
2617     }
2618     TclDecrRefCount(valueObj);
2619
2620     /*
2621      * Run the script.
2622      */
2623
2624     TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
2625     return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
2626             iPtr->cmdFramePtr, 3);
2627
2628     /*
2629      * For unwinding everything on error.
2630      */
2631
2632   error:
2633     TclDecrRefCount(storagePtr->keyVarObj);
2634     TclDecrRefCount(storagePtr->valueVarObj);
2635     TclDecrRefCount(storagePtr->scriptObj);
2636     TclDecrRefCount(storagePtr->accumulatorObj);
2637     Tcl_DictObjDone(&storagePtr->search);
2638     TclStackFree(interp, storagePtr);
2639     return TCL_ERROR;
2640 }
2641
2642 static int
2643 DictMapLoopCallback(
2644     ClientData data[],
2645     Tcl_Interp *interp,
2646     int result)
2647 {
2648     Interp *iPtr = (Interp *) interp;
2649     DictMapStorage *storagePtr = data[0];
2650     Tcl_Obj *keyObj, *valueObj;
2651     int done;
2652
2653     /*
2654      * Process the result from the previous execution of the script body.
2655      */
2656
2657     if (result == TCL_CONTINUE) {
2658         result = TCL_OK;
2659     } else if (result != TCL_OK) {
2660         if (result == TCL_BREAK) {
2661             Tcl_ResetResult(interp);
2662             result = TCL_OK;
2663         } else if (result == TCL_ERROR) {
2664             Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
2665                     "\n    (\"dict map\" body line %d)",
2666                     Tcl_GetErrorLine(interp)));
2667         }
2668         goto done;
2669     } else {
2670         keyObj = Tcl_ObjGetVar2(interp, storagePtr->keyVarObj, NULL,
2671                 TCL_LEAVE_ERR_MSG);
2672         if (keyObj == NULL) {
2673             result = TCL_ERROR;
2674             goto done;
2675         }
2676         Tcl_DictObjPut(NULL, storagePtr->accumulatorObj, keyObj,
2677                 Tcl_GetObjResult(interp));
2678     }
2679
2680     /*
2681      * Get the next mapping from the dictionary.
2682      */
2683
2684     Tcl_DictObjNext(&storagePtr->search, &keyObj, &valueObj, &done);
2685     if (done) {
2686         Tcl_SetObjResult(interp, storagePtr->accumulatorObj);
2687         goto done;
2688     }
2689
2690     /*
2691      * Stop the value from getting hit in any way by any traces on the key
2692      * variable.
2693      */
2694
2695     Tcl_IncrRefCount(valueObj);
2696     if (Tcl_ObjSetVar2(interp, storagePtr->keyVarObj, NULL, keyObj,
2697             TCL_LEAVE_ERR_MSG) == NULL) {
2698         TclDecrRefCount(valueObj);
2699         result = TCL_ERROR;
2700         goto done;
2701     }
2702     if (Tcl_ObjSetVar2(interp, storagePtr->valueVarObj, NULL, valueObj,
2703             TCL_LEAVE_ERR_MSG) == NULL) {
2704         TclDecrRefCount(valueObj);
2705         result = TCL_ERROR;
2706         goto done;
2707     }
2708     TclDecrRefCount(valueObj);
2709
2710     /*
2711      * Run the script.
2712      */
2713
2714     TclNRAddCallback(interp, DictMapLoopCallback, storagePtr, NULL,NULL,NULL);
2715     return TclNREvalObjEx(interp, storagePtr->scriptObj, 0,
2716             iPtr->cmdFramePtr, 3);
2717
2718     /*
2719      * For unwinding everything once the iterating is done.
2720      */
2721
2722   done:
2723     TclDecrRefCount(storagePtr->keyVarObj);
2724     TclDecrRefCount(storagePtr->valueVarObj);
2725     TclDecrRefCount(storagePtr->scriptObj);
2726     TclDecrRefCount(storagePtr->accumulatorObj);
2727     Tcl_DictObjDone(&storagePtr->search);
2728     TclStackFree(interp, storagePtr);
2729     return result;
2730 }
2731 \f
2732 /*
2733  *----------------------------------------------------------------------
2734  *
2735  * DictSetCmd --
2736  *
2737  *      This function implements the "dict set" Tcl command. See the user
2738  *      documentation for details on what it does, and TIP#111 for the formal
2739  *      specification.
2740  *
2741  * Results:
2742  *      A standard Tcl result.
2743  *
2744  * Side effects:
2745  *      See the user documentation.
2746  *
2747  *----------------------------------------------------------------------
2748  */
2749
2750 static int
2751 DictSetCmd(
2752     ClientData dummy,
2753     Tcl_Interp *interp,
2754     int objc,
2755     Tcl_Obj *const *objv)
2756 {
2757     Tcl_Obj *dictPtr, *resultPtr;
2758     int result, allocatedDict = 0;
2759
2760     if (objc < 4) {
2761         Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...? value");
2762         return TCL_ERROR;
2763     }
2764
2765     dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
2766     if (dictPtr == NULL) {
2767         allocatedDict = 1;
2768         dictPtr = Tcl_NewDictObj();
2769     } else if (Tcl_IsShared(dictPtr)) {
2770         allocatedDict = 1;
2771         dictPtr = Tcl_DuplicateObj(dictPtr);
2772     }
2773
2774     result = Tcl_DictObjPutKeyList(interp, dictPtr, objc-3, objv+2,
2775             objv[objc-1]);
2776     if (result != TCL_OK) {
2777         if (allocatedDict) {
2778             TclDecrRefCount(dictPtr);
2779         }
2780         return TCL_ERROR;
2781     }
2782
2783     resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
2784             TCL_LEAVE_ERR_MSG);
2785     if (resultPtr == NULL) {
2786         return TCL_ERROR;
2787     }
2788     Tcl_SetObjResult(interp, resultPtr);
2789     return TCL_OK;
2790 }
2791 \f
2792 /*
2793  *----------------------------------------------------------------------
2794  *
2795  * DictUnsetCmd --
2796  *
2797  *      This function implements the "dict unset" Tcl command. See the user
2798  *      documentation for details on what it does, and TIP#111 for the formal
2799  *      specification.
2800  *
2801  * Results:
2802  *      A standard Tcl result.
2803  *
2804  * Side effects:
2805  *      See the user documentation.
2806  *
2807  *----------------------------------------------------------------------
2808  */
2809
2810 static int
2811 DictUnsetCmd(
2812     ClientData dummy,
2813     Tcl_Interp *interp,
2814     int objc,
2815     Tcl_Obj *const *objv)
2816 {
2817     Tcl_Obj *dictPtr, *resultPtr;
2818     int result, allocatedDict = 0;
2819
2820     if (objc < 3) {
2821         Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...?");
2822         return TCL_ERROR;
2823     }
2824
2825     dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
2826     if (dictPtr == NULL) {
2827         allocatedDict = 1;
2828         dictPtr = Tcl_NewDictObj();
2829     } else if (Tcl_IsShared(dictPtr)) {
2830         allocatedDict = 1;
2831         dictPtr = Tcl_DuplicateObj(dictPtr);
2832     }
2833
2834     result = Tcl_DictObjRemoveKeyList(interp, dictPtr, objc-2, objv+2);
2835     if (result != TCL_OK) {
2836         if (allocatedDict) {
2837             TclDecrRefCount(dictPtr);
2838         }
2839         return TCL_ERROR;
2840     }
2841
2842     resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
2843             TCL_LEAVE_ERR_MSG);
2844     if (resultPtr == NULL) {
2845         return TCL_ERROR;
2846     }
2847     Tcl_SetObjResult(interp, resultPtr);
2848     return TCL_OK;
2849 }
2850 \f
2851 /*
2852  *----------------------------------------------------------------------
2853  *
2854  * DictFilterCmd --
2855  *
2856  *      This function implements the "dict filter" Tcl command. See the user
2857  *      documentation for details on what it does, and TIP#111 for the formal
2858  *      specification.
2859  *
2860  * Results:
2861  *      A standard Tcl result.
2862  *
2863  * Side effects:
2864  *      See the user documentation.
2865  *
2866  *----------------------------------------------------------------------
2867  */
2868
2869 static int
2870 DictFilterCmd(
2871     ClientData dummy,
2872     Tcl_Interp *interp,
2873     int objc,
2874     Tcl_Obj *const *objv)
2875 {
2876     Interp *iPtr = (Interp *) interp;
2877     static const char *const filters[] = {
2878         "key", "script", "value", NULL
2879     };
2880     enum FilterTypes {
2881         FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
2882     };
2883     Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
2884     Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
2885     Tcl_DictSearch search;
2886     int index, varc, done, result, satisfied;
2887     const char *pattern;
2888
2889     if (objc < 3) {
2890         Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
2891         return TCL_ERROR;
2892     }
2893     if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
2894              0, &index) != TCL_OK) {
2895         return TCL_ERROR;
2896     }
2897
2898     switch ((enum FilterTypes) index) {
2899     case FILTER_KEYS:
2900         /*
2901          * Create a dictionary whose keys all match a certain pattern.
2902          */
2903
2904         if (Tcl_DictObjFirst(interp, objv[1], &search,
2905                 &keyObj, &valueObj, &done) != TCL_OK) {
2906             return TCL_ERROR;
2907         }
2908         if (objc == 3) {
2909             /*
2910              * Nothing to match, so return nothing (== empty dictionary).
2911              */
2912
2913             Tcl_DictObjDone(&search);
2914             return TCL_OK;
2915         } else if (objc == 4) {
2916             pattern = TclGetString(objv[3]);
2917             resultObj = Tcl_NewDictObj();
2918             if (TclMatchIsTrivial(pattern)) {
2919                 /*
2920                  * Must release the search lock here to prevent a memory leak
2921                  * since we are not exhausing the search. [Bug 1705778, leak
2922                  * K05]
2923                  */
2924
2925                 Tcl_DictObjDone(&search);
2926                 Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj);
2927                 if (valueObj != NULL) {
2928                     Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj);
2929                 }
2930             } else {
2931                 while (!done) {
2932                     if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
2933                         Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
2934                     }
2935                     Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
2936                 }
2937             }
2938         } else {
2939             /*
2940              * Can't optimize this match for trivial globbing: would disturb
2941              * order.
2942              */
2943
2944             resultObj = Tcl_NewDictObj();
2945             while (!done) {
2946                 int i;
2947
2948                 for (i=3 ; i<objc ; i++) {
2949                     pattern = TclGetString(objv[i]);
2950                     if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
2951                         Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
2952                         break;          /* stop inner loop */
2953                     }
2954                 }
2955                 Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
2956             }
2957         }
2958         Tcl_SetObjResult(interp, resultObj);
2959         return TCL_OK;
2960
2961     case FILTER_VALUES:
2962         /*
2963          * Create a dictionary whose values all match a certain pattern.
2964          */
2965
2966         if (Tcl_DictObjFirst(interp, objv[1], &search,
2967                 &keyObj, &valueObj, &done) != TCL_OK) {
2968             return TCL_ERROR;
2969         }
2970         resultObj = Tcl_NewDictObj();
2971         while (!done) {
2972             int i;
2973
2974             for (i=3 ; i<objc ; i++) {
2975                 pattern = TclGetString(objv[i]);
2976                 if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
2977                     Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
2978                     break;              /* stop inner loop */
2979                 }
2980             }
2981             Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
2982         }
2983         Tcl_SetObjResult(interp, resultObj);
2984         return TCL_OK;
2985
2986     case FILTER_SCRIPT:
2987         if (objc != 5) {
2988             Tcl_WrongNumArgs(interp, 1, objv,
2989                     "dictionary script {keyVarName valueVarName} filterScript");
2990             return TCL_ERROR;
2991         }
2992
2993         /*
2994          * Create a dictionary whose key,value pairs all satisfy a script
2995          * (i.e. get a true boolean result from its evaluation). Massive
2996          * copying from the "dict for" implementation has occurred!
2997          */
2998
2999         if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
3000             return TCL_ERROR;
3001         }
3002         if (varc != 2) {
3003             Tcl_SetObjResult(interp, Tcl_NewStringObj(
3004                     "must have exactly two variable names", -1));
3005             Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL);
3006             return TCL_ERROR;
3007         }
3008         keyVarObj = varv[0];
3009         valueVarObj = varv[1];
3010         scriptObj = objv[4];
3011
3012         /*
3013          * Make sure that these objects (which we need throughout the body of
3014          * the loop) don't vanish. Note that the dictionary internal rep is
3015          * locked internally so that updates, shimmering, etc are not a
3016          * problem.
3017          */
3018
3019         Tcl_IncrRefCount(keyVarObj);
3020         Tcl_IncrRefCount(valueVarObj);
3021         Tcl_IncrRefCount(scriptObj);
3022
3023         result = Tcl_DictObjFirst(interp, objv[1],
3024                 &search, &keyObj, &valueObj, &done);
3025         if (result != TCL_OK) {
3026             TclDecrRefCount(keyVarObj);
3027             TclDecrRefCount(valueVarObj);
3028             TclDecrRefCount(scriptObj);
3029             return TCL_ERROR;
3030         }
3031
3032         resultObj = Tcl_NewDictObj();
3033
3034         while (!done) {
3035             /*
3036              * Stop the value from getting hit in any way by any traces on the
3037              * key variable.
3038              */
3039
3040             Tcl_IncrRefCount(keyObj);
3041             Tcl_IncrRefCount(valueObj);
3042             if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
3043                     TCL_LEAVE_ERR_MSG) == NULL) {
3044                 Tcl_AddErrorInfo(interp,
3045                         "\n    (\"dict filter\" filter script key variable)");
3046                 result = TCL_ERROR;
3047                 goto abnormalResult;
3048             }
3049             if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
3050                     TCL_LEAVE_ERR_MSG) == NULL) {
3051                 Tcl_AddErrorInfo(interp,
3052                         "\n    (\"dict filter\" filter script value variable)");
3053                 result = TCL_ERROR;
3054                 goto abnormalResult;
3055             }
3056
3057             /*
3058              * TIP #280. Make invoking context available to loop body.
3059              */
3060
3061             result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 4);
3062             switch (result) {
3063             case TCL_OK:
3064                 boolObj = Tcl_GetObjResult(interp);
3065                 Tcl_IncrRefCount(boolObj);
3066                 Tcl_ResetResult(interp);
3067                 if (Tcl_GetBooleanFromObj(interp, boolObj,
3068                         &satisfied) != TCL_OK) {
3069                     TclDecrRefCount(boolObj);
3070                     result = TCL_ERROR;
3071                     goto abnormalResult;
3072                 }
3073                 TclDecrRefCount(boolObj);
3074                 if (satisfied) {
3075                     Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
3076                 }
3077                 break;
3078             case TCL_BREAK:
3079                 /*
3080                  * Force loop termination by calling Tcl_DictObjDone; this
3081                  * makes the next Tcl_DictObjNext say there is nothing more to
3082                  * do.
3083                  */
3084
3085                 Tcl_ResetResult(interp);
3086                 Tcl_DictObjDone(&search);
3087             /* FALLTHRU */
3088             case TCL_CONTINUE:
3089                 result = TCL_OK;
3090                 break;
3091             case TCL_ERROR:
3092                 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
3093                         "\n    (\"dict filter\" script line %d)",
3094                         Tcl_GetErrorLine(interp)));
3095             default:
3096                 goto abnormalResult;
3097             }
3098
3099             TclDecrRefCount(keyObj);
3100             TclDecrRefCount(valueObj);
3101
3102             Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
3103         }
3104
3105         /*
3106          * Stop holding a reference to these objects.
3107          */
3108
3109         TclDecrRefCount(keyVarObj);
3110         TclDecrRefCount(valueVarObj);
3111         TclDecrRefCount(scriptObj);
3112         Tcl_DictObjDone(&search);
3113
3114         if (result == TCL_OK) {
3115             Tcl_SetObjResult(interp, resultObj);
3116         } else {
3117             TclDecrRefCount(resultObj);
3118         }
3119         return result;
3120
3121     abnormalResult:
3122         Tcl_DictObjDone(&search);
3123         TclDecrRefCount(keyObj);
3124         TclDecrRefCount(valueObj);
3125         TclDecrRefCount(keyVarObj);
3126         TclDecrRefCount(valueVarObj);
3127         TclDecrRefCount(scriptObj);
3128         TclDecrRefCount(resultObj);
3129         return result;
3130     }
3131     Tcl_Panic("unexpected fallthrough");
3132     /* Control never reaches this point. */
3133     return TCL_ERROR;
3134 }
3135 \f
3136 /*
3137  *----------------------------------------------------------------------
3138  *
3139  * DictUpdateCmd --
3140  *
3141  *      This function implements the "dict update" Tcl command. See the user
3142  *      documentation for details on what it does, and TIP#212 for the formal
3143  *      specification.
3144  *
3145  * Results:
3146  *      A standard Tcl result.
3147  *
3148  * Side effects:
3149  *      See the user documentation.
3150  *
3151  *----------------------------------------------------------------------
3152  */
3153
3154 static int
3155 DictUpdateCmd(
3156     ClientData clientData,
3157     Tcl_Interp *interp,
3158     int objc,
3159     Tcl_Obj *const *objv)
3160 {
3161     Interp *iPtr = (Interp *) interp;
3162     Tcl_Obj *dictPtr, *objPtr;
3163     int i, dummy;
3164
3165     if (objc < 5 || !(objc & 1)) {
3166         Tcl_WrongNumArgs(interp, 1, objv,
3167                 "dictVarName key varName ?key varName ...? script");
3168         return TCL_ERROR;
3169     }
3170
3171     dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
3172     if (dictPtr == NULL) {
3173         return TCL_ERROR;
3174     }
3175     if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) {
3176         return TCL_ERROR;
3177     }
3178     Tcl_IncrRefCount(dictPtr);
3179     for (i=2 ; i+2<objc ; i+=2) {
3180         if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
3181             TclDecrRefCount(dictPtr);
3182             return TCL_ERROR;
3183         }
3184         if (objPtr == NULL) {
3185             /* ??? */
3186             Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0);
3187         } else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
3188                 TCL_LEAVE_ERR_MSG) == NULL) {
3189             TclDecrRefCount(dictPtr);
3190             return TCL_ERROR;
3191         }
3192     }
3193     TclDecrRefCount(dictPtr);
3194
3195     /*
3196      * Execute the body after setting up the NRE handler to process the
3197      * results.
3198      */
3199
3200     objPtr = Tcl_NewListObj(objc-3, objv+2);
3201     Tcl_IncrRefCount(objPtr);
3202     Tcl_IncrRefCount(objv[1]);
3203     TclNRAddCallback(interp, FinalizeDictUpdate, objv[1], objPtr, NULL,NULL);
3204
3205     return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
3206 }
3207
3208 static int
3209 FinalizeDictUpdate(
3210     ClientData data[],
3211     Tcl_Interp *interp,
3212     int result)
3213 {
3214     Tcl_Obj *dictPtr, *objPtr, **objv;
3215     Tcl_InterpState state;
3216     int i, objc;
3217     Tcl_Obj *varName = data[0];
3218     Tcl_Obj *argsObj = data[1];
3219
3220     /*
3221      * ErrorInfo handling.
3222      */
3223
3224     if (result == TCL_ERROR) {
3225         Tcl_AddErrorInfo(interp, "\n    (body of \"dict update\")");
3226     }
3227
3228     /*
3229      * If the dictionary variable doesn't exist, drop everything silently.
3230      */
3231
3232     dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0);
3233     if (dictPtr == NULL) {
3234         TclDecrRefCount(varName);
3235         TclDecrRefCount(argsObj);
3236         return result;
3237     }
3238
3239     /*
3240      * Double-check that it is still a dictionary.
3241      */
3242
3243     state = Tcl_SaveInterpState(interp, result);
3244     if (Tcl_DictObjSize(interp, dictPtr, &objc) != TCL_OK) {
3245         Tcl_DiscardInterpState(state);
3246         TclDecrRefCount(varName);
3247         TclDecrRefCount(argsObj);
3248         return TCL_ERROR;
3249     }
3250
3251     if (Tcl_IsShared(dictPtr)) {
3252         dictPtr = Tcl_DuplicateObj(dictPtr);
3253     }
3254
3255     /*
3256      * Write back the values from the variables, treating failure to read as
3257      * an instruction to remove the key.
3258      */
3259
3260     Tcl_ListObjGetElements(NULL, argsObj, &objc, &objv);
3261     for (i=0 ; i<objc ; i+=2) {
3262         objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
3263         if (objPtr == NULL) {
3264             Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
3265         } else if (objPtr == dictPtr) {
3266             /*
3267              * Someone is messing us around, trying to build a recursive
3268              * structure. [Bug 1786481]
3269              */
3270
3271             Tcl_DictObjPut(NULL, dictPtr, objv[i], Tcl_DuplicateObj(objPtr));
3272         } else {
3273             /* Shouldn't fail */
3274             Tcl_DictObjPut(NULL, dictPtr, objv[i], objPtr);
3275         }
3276     }
3277     TclDecrRefCount(argsObj);
3278
3279     /*
3280      * Write the dictionary back to its variable.
3281      */
3282
3283     if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
3284             TCL_LEAVE_ERR_MSG) == NULL) {
3285         Tcl_DiscardInterpState(state);
3286         TclDecrRefCount(varName);
3287         return TCL_ERROR;
3288     }
3289
3290     TclDecrRefCount(varName);
3291     return Tcl_RestoreInterpState(interp, state);
3292 }
3293 \f
3294 /*
3295  *----------------------------------------------------------------------
3296  *
3297  * DictWithCmd --
3298  *
3299  *      This function implements the "dict with" Tcl command. See the user
3300  *      documentation for details on what it does, and TIP#212 for the formal
3301  *      specification.
3302  *
3303  * Results:
3304  *      A standard Tcl result.
3305  *
3306  * Side effects:
3307  *      See the user documentation.
3308  *
3309  *----------------------------------------------------------------------
3310  */
3311
3312 static int
3313 DictWithCmd(
3314     ClientData dummy,
3315     Tcl_Interp *interp,
3316     int objc,
3317     Tcl_Obj *const *objv)
3318 {
3319     Interp *iPtr = (Interp *) interp;
3320     Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
3321
3322     if (objc < 3) {
3323         Tcl_WrongNumArgs(interp, 1, objv, "dictVarName ?key ...? script");
3324         return TCL_ERROR;
3325     }
3326
3327     /*
3328      * Get the dictionary to open out.
3329      */
3330
3331     dictPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
3332     if (dictPtr == NULL) {
3333         return TCL_ERROR;
3334     }
3335
3336     keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2);
3337     if (keysPtr == NULL) {
3338         return TCL_ERROR;
3339     }
3340     Tcl_IncrRefCount(keysPtr);
3341
3342     /*
3343      * Execute the body, while making the invoking context available to the
3344      * loop body (TIP#280) and postponing the cleanup until later (NRE).
3345      */
3346
3347     pathPtr = NULL;
3348     if (objc > 3) {
3349         pathPtr = Tcl_NewListObj(objc-3, objv+2);
3350         Tcl_IncrRefCount(pathPtr);
3351     }
3352     Tcl_IncrRefCount(objv[1]);
3353     TclNRAddCallback(interp, FinalizeDictWith, objv[1], keysPtr, pathPtr,
3354             NULL);
3355
3356     return TclNREvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1);
3357 }
3358
3359 static int
3360 FinalizeDictWith(
3361     ClientData data[],
3362     Tcl_Interp *interp,
3363     int result)
3364 {
3365     Tcl_Obj **pathv;
3366     int pathc;
3367     Tcl_InterpState state;
3368     Tcl_Obj *varName = data[0];
3369     Tcl_Obj *keysPtr = data[1];
3370     Tcl_Obj *pathPtr = data[2];
3371     Var *varPtr, *arrayPtr;
3372
3373     if (result == TCL_ERROR) {
3374         Tcl_AddErrorInfo(interp, "\n    (body of \"dict with\")");
3375     }
3376
3377     /*
3378      * Save the result state; TDWF doesn't guarantee to not modify that on
3379      * TCL_OK result.
3380      */
3381
3382     state = Tcl_SaveInterpState(interp, result);
3383     if (pathPtr != NULL) {
3384         Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv);
3385     } else {
3386         pathc = 0;
3387         pathv = NULL;
3388     }
3389
3390     /*
3391      * Pack from local variables back into the dictionary.
3392      */
3393
3394     varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set",
3395             /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
3396     if (varPtr == NULL) {
3397         result = TCL_ERROR;
3398     } else {
3399         result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1,
3400                 pathc, pathv, keysPtr);
3401     }
3402
3403     /*
3404      * Tidy up and return the real result (unless we had an error).
3405      */
3406
3407     TclDecrRefCount(varName);
3408     TclDecrRefCount(keysPtr);
3409     if (pathPtr != NULL) {
3410         TclDecrRefCount(pathPtr);
3411     }
3412     if (result != TCL_OK) {
3413         Tcl_DiscardInterpState(state);
3414         return TCL_ERROR;
3415     }
3416     return Tcl_RestoreInterpState(interp, state);
3417 }
3418 \f
3419 /*
3420  *----------------------------------------------------------------------
3421  *
3422  * TclDictWithInit --
3423  *
3424  *      Part of the core of [dict with]. Pokes into a dictionary and converts
3425  *      the mappings there into assignments to (presumably) local variables.
3426  *      Returns a list of all the names that were mapped so that removal of
3427  *      either the variable or the dictionary entry won't surprise us when we
3428  *      come to stuffing everything back.
3429  *
3430  * Result:
3431  *      List of mapped names, or NULL if there was an error.
3432  *
3433  * Side effects:
3434  *      Assigns to variables, so potentially legion due to traces.
3435  *
3436  *----------------------------------------------------------------------
3437  */
3438
3439 Tcl_Obj *
3440 TclDictWithInit(
3441     Tcl_Interp *interp,
3442     Tcl_Obj *dictPtr,
3443     int pathc,
3444     Tcl_Obj *const pathv[])
3445 {
3446     Tcl_DictSearch s;
3447     Tcl_Obj *keyPtr, *valPtr, *keysPtr;
3448     int done;
3449
3450     if (pathc > 0) {
3451         dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
3452                 DICT_PATH_READ);
3453         if (dictPtr == NULL) {
3454             return NULL;
3455         }
3456     }
3457
3458     /*
3459      * Go over the list of keys and write each corresponding value to a
3460      * variable in the current context with the same name. Also keep a copy of
3461      * the keys so we can write back properly later on even if the dictionary
3462      * has been structurally modified.
3463      */
3464
3465     if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
3466             &done) != TCL_OK) {
3467         return NULL;
3468     }
3469
3470     TclNewObj(keysPtr);
3471
3472     for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
3473         Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
3474         if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
3475                 TCL_LEAVE_ERR_MSG) == NULL) {
3476             TclDecrRefCount(keysPtr);
3477             Tcl_DictObjDone(&s);
3478             return NULL;
3479         }
3480     }
3481
3482     return keysPtr;
3483 }
3484 \f
3485 /*
3486  *----------------------------------------------------------------------
3487  *
3488  * TclDictWithFinish --
3489  *
3490  *      Part of the core of [dict with]. Reassembles the piece of the dict (in
3491  *      varName, location given by pathc/pathv) from the variables named in
3492  *      the keysPtr argument. NB, does not try to preserve errors or manage
3493  *      argument lifetimes.
3494  *
3495  * Result:
3496  *      TCL_OK if we succeeded, or TCL_ERROR if we failed.
3497  *
3498  * Side effects:
3499  *      Assigns to a variable, so potentially legion due to traces. Updates
3500  *      the dictionary in the named variable.
3501  *
3502  *----------------------------------------------------------------------
3503  */
3504
3505 int
3506 TclDictWithFinish(
3507     Tcl_Interp *interp,         /* Command interpreter in which variable
3508                                  * exists. Used for state management, traces
3509                                  * and error reporting. */
3510     Var *varPtr,                /* Reference to the variable holding the
3511                                  * dictionary. */
3512     Var *arrayPtr,              /* Reference to the array containing the
3513                                  * variable, or NULL if the variable is a
3514                                  * scalar. */
3515     Tcl_Obj *part1Ptr,          /* Name of an array (if part2 is non-NULL) or
3516                                  * the name of a variable. NULL if the 'index'
3517                                  * parameter is >= 0 */
3518     Tcl_Obj *part2Ptr,          /* If non-NULL, gives the name of an element
3519                                  * in the array part1. */
3520     int index,                  /* Index into the local variable table of the
3521                                  * variable, or -1. Only used when part1Ptr is
3522                                  * NULL. */
3523     int pathc,                  /* The number of elements in the path into the
3524                                  * dictionary. */
3525     Tcl_Obj *const pathv[],     /* The elements of the path to the subdict. */
3526     Tcl_Obj *keysPtr)           /* List of keys to be synchronized. This is
3527                                  * the result value from TclDictWithInit. */
3528 {
3529     Tcl_Obj *dictPtr, *leafPtr, *valPtr;
3530     int i, allocdict, keyc;
3531     Tcl_Obj **keyv;
3532
3533     /*
3534      * If the dictionary variable doesn't exist, drop everything silently.
3535      */
3536
3537     dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
3538             TCL_LEAVE_ERR_MSG, index);
3539     if (dictPtr == NULL) {
3540         return TCL_OK;
3541     }
3542
3543     /*
3544      * Double-check that it is still a dictionary.
3545      */
3546
3547     if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) {
3548         return TCL_ERROR;
3549     }
3550
3551     if (Tcl_IsShared(dictPtr)) {
3552         dictPtr = Tcl_DuplicateObj(dictPtr);
3553         allocdict = 1;
3554     } else {
3555         allocdict = 0;
3556     }
3557
3558     if (pathc > 0) {
3559         /*
3560          * Want to get to the dictionary which we will update; need to do
3561          * prepare-for-update de-sharing along the path *but* avoid generating
3562          * an error on a non-existant path (we'll treat that the same as a
3563          * non-existant variable. Luckily, the de-sharing operation isn't
3564          * deeply damaging if we don't go on to update; it's just less than
3565          * perfectly efficient (but no memory should be leaked).
3566          */
3567
3568         leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
3569                 DICT_PATH_EXISTS | DICT_PATH_UPDATE);
3570         if (leafPtr == NULL) {
3571             if (allocdict) {
3572                 TclDecrRefCount(dictPtr);
3573             }
3574             return TCL_ERROR;
3575         }
3576         if (leafPtr == DICT_PATH_NON_EXISTENT) {
3577             if (allocdict) {
3578                 TclDecrRefCount(dictPtr);
3579             }
3580             return TCL_OK;
3581         }
3582     } else {
3583         leafPtr = dictPtr;
3584     }
3585
3586     /*
3587      * Now process our updates on the leaf dictionary.
3588      */
3589
3590     TclListObjGetElements(NULL, keysPtr, &keyc, &keyv);
3591     for (i=0 ; i<keyc ; i++) {
3592         valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
3593         if (valPtr == NULL) {
3594             Tcl_DictObjRemove(NULL, leafPtr, keyv[i]);
3595         } else if (leafPtr == valPtr) {
3596             /*
3597              * Someone is messing us around, trying to build a recursive
3598              * structure. [Bug 1786481]
3599              */
3600
3601             Tcl_DictObjPut(NULL, leafPtr, keyv[i], Tcl_DuplicateObj(valPtr));
3602         } else {
3603             Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr);
3604         }
3605     }
3606
3607     /*
3608      * Ensure that none of the dictionaries in the chain still have a string
3609      * rep.
3610      */
3611
3612     if (pathc > 0) {
3613         InvalidateDictChain(leafPtr);
3614     }
3615
3616     /*
3617      * Write back the outermost dictionary to the variable.
3618      */
3619
3620     if (TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
3621             dictPtr, TCL_LEAVE_ERR_MSG, index) == NULL) {
3622         if (allocdict) {
3623             TclDecrRefCount(dictPtr);
3624         }
3625         return TCL_ERROR;
3626     }
3627     return TCL_OK;
3628 }
3629 \f
3630 /*
3631  *----------------------------------------------------------------------
3632  *
3633  * TclInitDictCmd --
3634  *
3635  *      This function is create the "dict" Tcl command. See the user
3636  *      documentation for details on what it does, and TIP#111 for the formal
3637  *      specification.
3638  *
3639  * Results:
3640  *      A Tcl command handle.
3641  *
3642  * Side effects:
3643  *      May advance compilation epoch.
3644  *
3645  *----------------------------------------------------------------------
3646  */
3647
3648 Tcl_Command
3649 TclInitDictCmd(
3650     Tcl_Interp *interp)
3651 {
3652     return TclMakeEnsemble(interp, "dict", implementationMap);
3653 }
3654 \f
3655 /*
3656  * Local Variables:
3657  * mode: c
3658  * c-basic-offset: 4
3659  * fill-column: 78
3660  * End:
3661  */