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