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