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