1/* 2 * tclXkeylist.c -- 3 * 4 * Extended Tcl keyed list commands and interfaces. 5 *----------------------------------------------------------------------------- 6 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. 7 * 8 * Permission to use, copy, modify, and distribute this software and its 9 * documentation for any purpose and without fee is hereby granted, provided 10 * that the above copyright notice appear in all copies. Karl Lehenbauer and 11 * Mark Diekhans make no representations about the suitability of this 12 * software for any purpose. It is provided "as is" without express or 13 * implied warranty. 14 * 15 *----------------------------------------------------------------------------- 16 * 17 * This file was synthetized from the TclX distribution and made 18 * self-containing in order to encapsulate the keyed list datatype 19 * for the inclusion in the Tcl threading extension. I have made 20 * some minor changes to it in order to get internal object handling 21 * thread-safe and allow for this datatype to be used from within 22 * the thread shared variables implementation. 23 * 24 * For any questions, contant Zoran Vasiljevic (zoran@archiware.com) 25 * 26 *----------------------------------------------------------------------------- 27 * $Id: tclXkeylist.c,v 1.6 2010/04/01 22:17:42 vasiljevic Exp $ 28 *----------------------------------------------------------------------------- 29 */ 30 31#include "threadSvCmd.h" 32#include "tclXkeylist.h" 33 34/*---------------------------------------------------------------------------*/ 35/*---------------------------------------------------------------------------*/ 36/* Stuff copied verbatim from the rest of TclX to avoid dependencies */ 37/*---------------------------------------------------------------------------*/ 38/*---------------------------------------------------------------------------*/ 39 40/* 41 * Assert macro for use in TclX. Some GCCs libraries are missing a function 42 * used by their macro, so we define out own. 43 */ 44 45#ifdef TCLX_DEBUG 46# define TclX_Assert(expr) ((expr) ? (void)0 : \ 47 panic("TclX assertion failure: %s:%d \"%s\"\n",\ 48 __FILE__, __LINE__, "expr")) 49#else 50# define TclX_Assert(expr) 51#endif 52 53#define TRUE 1 54#define FALSE 0 55 56/* 57 * Macro that behaves like strdup, only uses ckalloc. Also macro that does the 58 * same with a string that might contain zero bytes, 59 */ 60 61#define ckstrdup(sourceStr) \ 62 (strcpy (ckalloc (strlen (sourceStr) + 1), sourceStr)) 63 64#define ckbinstrdup(sourceStr, length) \ 65 ((char *) memcpy (ckalloc (length + 1), sourceStr, length + 1)) 66 67/* 68 * Used to return argument messages by most commands. 69 */ 70static const char *tclXWrongArgs = "wrong # args: "; 71 72static const Tcl_ObjType *listType; 73static const Tcl_ObjType *stringType; 74 75/*----------------------------------------------------------------------------- 76 * TclX_IsNullObj -- 77 * 78 * Check if an object is {}, either in list or zero-lemngth string form, with 79 * out forcing a conversion. 80 * 81 * Parameters: 82 * o objPtr - Object to check. 83 * Returns: 84 * True if NULL, FALSE if not. 85 *----------------------------------------------------------------------------- 86 */ 87static int 88TclX_IsNullObj (objPtr) 89 Tcl_Obj *objPtr; 90{ 91 int length; 92 93 if (objPtr->typePtr == NULL) { 94 return (objPtr->length == 0); 95 } else { 96 if (objPtr->typePtr == listType) { 97 Tcl_ListObjLength (NULL, objPtr, &length); 98 return (length == 0); 99 } else if (objPtr->typePtr == stringType) { 100 Tcl_GetStringFromObj (objPtr, &length); 101 return (length == 0); 102 } 103 } 104 Tcl_GetStringFromObj (objPtr, &length); 105 return (length == 0); 106} 107 108/*----------------------------------------------------------------------------- 109 * TclX_AppendObjResult -- 110 * 111 * Append a variable number of strings onto the object result already 112 * present for an interpreter. If the object is shared, the current contents 113 * are discarded. 114 * 115 * Parameters: 116 * o interp - Interpreter to set the result in. 117 * o args - Strings to append, terminated by a NULL. 118 *----------------------------------------------------------------------------- 119 */ 120static void 121TclX_AppendObjResult TCL_VARARGS_DEF (Tcl_Interp *, arg1) 122{ 123 Tcl_Interp *interp; 124 Tcl_Obj *resultPtr; 125 va_list argList; 126 char *string; 127 128 interp = TCL_VARARGS_START (Tcl_Interp *, arg1, argList); 129 resultPtr = Tcl_GetObjResult (interp); 130 131 if (Tcl_IsShared(resultPtr)) { 132 resultPtr = Tcl_NewStringObj((char *)NULL, 0); 133 Tcl_SetObjResult(interp, resultPtr); 134 } 135 136 TCL_VARARGS_START(Tcl_Interp *,arg1,argList); 137 while (1) { 138 string = va_arg(argList, char *); 139 if (string == NULL) { 140 break; 141 } 142 Tcl_AppendToObj (resultPtr, string, -1); 143 } 144 va_end(argList); 145} 146 147/*----------------------------------------------------------------------------- 148 * TclX_WrongArgs -- 149 * 150 * Easily create "wrong # args" error messages. 151 * 152 * Parameters: 153 * o commandNameObj - Object containing name of command (objv[0]) 154 * o string - Text message to append. 155 * Returns: 156 * TCL_ERROR 157 *----------------------------------------------------------------------------- 158 */ 159static int 160TclX_WrongArgs (interp, commandNameObj, string) 161 Tcl_Interp *interp; 162 Tcl_Obj *commandNameObj; 163 char *string; 164{ 165 const char *commandName; 166 Tcl_Obj *resultPtr = Tcl_GetObjResult (interp); 167 int commandLength; 168 169 commandName = Tcl_GetStringFromObj (commandNameObj, &commandLength); 170 171 Tcl_ResetResult(interp); 172 Tcl_AppendStringsToObj (resultPtr, 173 tclXWrongArgs, 174 commandName, 175 (char *)NULL); 176 177 if (*string != '\0') { 178 Tcl_AppendStringsToObj (resultPtr, " ", string, (char *)NULL); 179 } 180 return TCL_ERROR; 181} 182 183/*---------------------------------------------------------------------------*/ 184/*---------------------------------------------------------------------------*/ 185/* Here is where the original file begins */ 186/*---------------------------------------------------------------------------*/ 187/*---------------------------------------------------------------------------*/ 188 189/* 190 * Keyed lists are stored as arrays recursively defined objects. The data 191 * portion of a keyed list entry is a Tcl_Obj which may be a keyed list object 192 * or any other Tcl object. Since determine the structure of a keyed list is 193 * lazy (you don't know if an element is data or another keyed list) until it 194 * is accessed, the object can be transformed into a keyed list from a Tcl 195 * string or list. 196 */ 197 198/* 199 * An entry in a keyed list array. (FIX: Should key be object?) 200 */ 201typedef struct { 202 char *key; 203 Tcl_Obj *valuePtr; 204} keylEntry_t; 205 206/* 207 * Internal representation of a keyed list object. 208 */ 209typedef struct { 210 int arraySize; /* Current slots available in the array. */ 211 int numEntries; /* Number of actual entries in the array. */ 212 keylEntry_t *entries; /* Array of keyed list entries. */ 213} keylIntObj_t; 214 215/* 216 * Amount to increment array size by when it needs to grow. 217 */ 218#define KEYEDLIST_ARRAY_INCR_SIZE 16 219 220/* 221 * Macro to duplicate a child entry of a keyed list if it is share by more 222 * than the parent. 223 */ 224#define DupSharedKeyListChild(keylIntPtr, idx) \ 225 if (Tcl_IsShared (keylIntPtr->entries [idx].valuePtr)) { \ 226 keylIntPtr->entries [idx].valuePtr = \ 227 Tcl_DuplicateObj (keylIntPtr->entries [idx].valuePtr); \ 228 Tcl_IncrRefCount (keylIntPtr->entries [idx].valuePtr); \ 229 } 230 231/* 232 * Macros to validate an keyed list object or internal representation 233 */ 234#ifdef TCLX_DEBUG 235# define KEYL_OBJ_ASSERT(keylAPtr) {\ 236 TclX_Assert (keylAPtr->typePtr == &keyedListType); \ 237 ValidateKeyedList (keylAIntPtr); \ 238 } 239# define KEYL_REP_ASSERT(keylAIntPtr) \ 240 ValidateKeyedList (keylAIntPtr) 241#else 242# define KEYL_REP_ASSERT(keylAIntPtr) 243#endif 244 245 246/* 247 * Prototypes of internal functions. 248 */ 249#ifdef TCLX_DEBUG 250static void 251ValidateKeyedList _ANSI_ARGS_((keylIntObj_t *keylIntPtr)); 252#endif 253 254static int 255ValidateKey _ANSI_ARGS_((Tcl_Interp *interp, 256 const char *key, 257 int keyLen, 258 int isPath)); 259 260static keylIntObj_t * 261AllocKeyedListIntRep _ANSI_ARGS_((void)); 262 263static void 264FreeKeyedListData _ANSI_ARGS_((keylIntObj_t *keylIntPtr)); 265 266static void 267EnsureKeyedListSpace _ANSI_ARGS_((keylIntObj_t *keylIntPtr, 268 int newNumEntries)); 269 270static void 271DeleteKeyedListEntry _ANSI_ARGS_((keylIntObj_t *keylIntPtr, 272 int entryIdx)); 273 274static int 275FindKeyedListEntry _ANSI_ARGS_((keylIntObj_t *keylIntPtr, 276 const char *key, 277 int *keyLenPtr, 278 const char **nextSubKeyPtr)); 279 280static int 281ObjToKeyedListEntry _ANSI_ARGS_((Tcl_Interp *interp, 282 Tcl_Obj *objPtr, 283 keylEntry_t *entryPtr)); 284 285static void 286DupKeyedListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, 287 Tcl_Obj *copyPtr)); 288 289static void 290FreeKeyedListInternalRep _ANSI_ARGS_((Tcl_Obj *keylPtr)); 291 292static int 293SetKeyedListFromAny _ANSI_ARGS_((Tcl_Interp *interp, 294 Tcl_Obj *objPtr)); 295 296static void 297UpdateStringOfKeyedList _ANSI_ARGS_((Tcl_Obj *keylPtr)); 298 299static int 300Tcl_KeylgetObjCmd _ANSI_ARGS_((ClientData clientData, 301 Tcl_Interp *interp, 302 int objc, 303 Tcl_Obj *const objv[])); 304 305static int 306Tcl_KeylsetObjCmd _ANSI_ARGS_((ClientData clientData, 307 Tcl_Interp *interp, 308 int objc, 309 Tcl_Obj *const objv[])); 310 311static int 312Tcl_KeyldelObjCmd _ANSI_ARGS_((ClientData clientData, 313 Tcl_Interp *interp, 314 int objc, 315 Tcl_Obj *const objv[])); 316 317static int 318Tcl_KeylkeysObjCmd _ANSI_ARGS_((ClientData clientData, 319 Tcl_Interp *interp, 320 int objc, 321 Tcl_Obj *const objv[])); 322 323/* 324 * Type definition. 325 */ 326Tcl_ObjType keyedListType = { 327 "keyedList", /* name */ 328 FreeKeyedListInternalRep, /* freeIntRepProc */ 329 DupKeyedListInternalRep, /* dupIntRepProc */ 330 UpdateStringOfKeyedList, /* updateStringProc */ 331 SetKeyedListFromAny /* setFromAnyProc */ 332}; 333 334 335/*----------------------------------------------------------------------------- 336 * ValidateKeyedList -- 337 * Validate a keyed list (only when TCLX_DEBUG is enabled). 338 * Parameters: 339 * o keylIntPtr - Keyed list internal representation. 340 *----------------------------------------------------------------------------- 341 */ 342#ifdef TCLX_DEBUG 343static void 344ValidateKeyedList (keylIntPtr) 345 keylIntObj_t *keylIntPtr; 346{ 347 int idx; 348 349 TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); 350 TclX_Assert (keylIntPtr->arraySize >= 0); 351 TclX_Assert (keylIntPtr->numEntries >= 0); 352 TclX_Assert ((keylIntPtr->arraySize > 0) ? 353 (keylIntPtr->entries != NULL) : TRUE); 354 TclX_Assert ((keylIntPtr->numEntries > 0) ? 355 (keylIntPtr->entries != NULL) : TRUE); 356 357 for (idx = 0; idx < keylIntPtr->numEntries; idx++) { 358 keylEntry_t *entryPtr = &(keylIntPtr->entries [idx]); 359 TclX_Assert (entryPtr->key != NULL); 360 TclX_Assert (entryPtr->valuePtr->refCount >= 1); 361 if (entryPtr->valuePtr->typePtr == &keyedListType) { 362 ValidateKeyedList (entryPtr->valuePtr->internalRep.otherValuePtr); 363 } 364 } 365} 366#endif 367 368/*----------------------------------------------------------------------------- 369 * ValidateKey -- 370 * Check that a key or keypath string is a valid value. 371 * 372 * Parameters: 373 * o interp - Used to return error messages. 374 * o key - Key string to check. 375 * o keyLen - Length of the string, used to check for binary data. 376 * o isPath - TRUE if this is a key path, FALSE if its a simple key and 377 * thus "." is illegal. 378 * Returns: 379 * TCL_OK or TCL_ERROR. 380 *----------------------------------------------------------------------------- 381 */ 382static int 383ValidateKey (interp, key, keyLen, isPath) 384 Tcl_Interp *interp; 385 const char *key; 386 int keyLen; 387 int isPath; 388{ 389 const char *keyp; 390 391 if (strlen (key) != (size_t) keyLen) { 392 Tcl_ResetResult(interp); 393 Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), 394 "keyed list key may not be a ", 395 "binary string", (char *) NULL); 396 return TCL_ERROR; 397 } 398 if (key [0] == '\0') { 399 Tcl_ResetResult(interp); 400 Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), 401 "keyed list key may not be an ", 402 "empty string", (char *) NULL); 403 return TCL_ERROR; 404 } 405 for (keyp = key; *keyp != '\0'; keyp++) { 406 if ((!isPath) && (*keyp == '.')) { 407 Tcl_ResetResult(interp); 408 Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), 409 "keyed list key may not contain a \".\"; ", 410 "it is used as a separator in key paths", 411 (char *) NULL); 412 return TCL_ERROR; 413 } 414 } 415 return TCL_OK; 416} 417 418 419/*----------------------------------------------------------------------------- 420 * AllocKeyedListIntRep -- 421 * Allocate an and initialize the keyed list internal representation. 422 * 423 * Returns: 424 * A pointer to the keyed list internal structure. 425 *----------------------------------------------------------------------------- 426 */ 427static keylIntObj_t * 428AllocKeyedListIntRep () 429{ 430 keylIntObj_t *keylIntPtr; 431 432 keylIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t)); 433 434 keylIntPtr->arraySize = 0; 435 keylIntPtr->numEntries = 0; 436 keylIntPtr->entries = NULL; 437 438 return keylIntPtr; 439} 440 441/*----------------------------------------------------------------------------- 442 * FreeKeyedListData -- 443 * Free the internal representation of a keyed list. 444 * 445 * Parameters: 446 * o keylIntPtr - Keyed list internal structure to free. 447 *----------------------------------------------------------------------------- 448 */ 449static void 450FreeKeyedListData (keylIntPtr) 451 keylIntObj_t *keylIntPtr; 452{ 453 int idx; 454 455 for (idx = 0; idx < keylIntPtr->numEntries ; idx++) { 456 ckfree (keylIntPtr->entries [idx].key); 457 Tcl_DecrRefCount (keylIntPtr->entries [idx].valuePtr); 458 } 459 if (keylIntPtr->entries != NULL) 460 ckfree ((char *) keylIntPtr->entries); 461 ckfree ((char *) keylIntPtr); 462} 463 464/*----------------------------------------------------------------------------- 465 * EnsureKeyedListSpace -- 466 * Ensure there is enough room in a keyed list array for a certain number 467 * of entries, expanding if necessary. 468 * 469 * Parameters: 470 * o keylIntPtr - Keyed list internal representation. 471 * o newNumEntries - The number of entries that are going to be added to 472 * the keyed list. 473 *----------------------------------------------------------------------------- 474 */ 475static void 476EnsureKeyedListSpace (keylIntPtr, newNumEntries) 477 keylIntObj_t *keylIntPtr; 478 int newNumEntries; 479{ 480 KEYL_REP_ASSERT (keylIntPtr); 481 482 if ((keylIntPtr->arraySize - keylIntPtr->numEntries) < newNumEntries) { 483 int newSize = keylIntPtr->arraySize + newNumEntries + 484 KEYEDLIST_ARRAY_INCR_SIZE; 485 if (keylIntPtr->entries == NULL) { 486 keylIntPtr->entries = (keylEntry_t *) 487 ckalloc (newSize * sizeof (keylEntry_t)); 488 } else { 489 keylIntPtr->entries = (keylEntry_t *) 490 ckrealloc ((VOID *) keylIntPtr->entries, 491 newSize * sizeof (keylEntry_t)); 492 } 493 keylIntPtr->arraySize = newSize; 494 } 495 496 KEYL_REP_ASSERT (keylIntPtr); 497} 498 499/*----------------------------------------------------------------------------- 500 * DeleteKeyedListEntry -- 501 * Delete an entry from a keyed list. 502 * 503 * Parameters: 504 * o keylIntPtr - Keyed list internal representation. 505 * o entryIdx - Index of entry to delete. 506 *----------------------------------------------------------------------------- 507 */ 508static void 509DeleteKeyedListEntry (keylIntPtr, entryIdx) 510 keylIntObj_t *keylIntPtr; 511 int entryIdx; 512{ 513 int idx; 514 515 ckfree (keylIntPtr->entries [entryIdx].key); 516 Tcl_DecrRefCount (keylIntPtr->entries [entryIdx].valuePtr); 517 518 for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++) 519 keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1]; 520 keylIntPtr->numEntries--; 521 522 KEYL_REP_ASSERT (keylIntPtr); 523} 524 525/*----------------------------------------------------------------------------- 526 * FindKeyedListEntry -- 527 * Find an entry in keyed list. 528 * 529 * Parameters: 530 * o keylIntPtr - Keyed list internal representation. 531 * o key - Name of key to search for. 532 * o keyLenPtr - In not NULL, the length of the key for this 533 * level is returned here. This excludes subkeys and the `.' delimiters. 534 * o nextSubKeyPtr - If not NULL, the start of the name of the next 535 * sub-key within key is returned. 536 * Returns: 537 * Index of the entry or -1 if not found. 538 *----------------------------------------------------------------------------- 539 */ 540static int 541FindKeyedListEntry (keylIntPtr, key, keyLenPtr, nextSubKeyPtr) 542 keylIntObj_t *keylIntPtr; 543 const char *key; 544 int *keyLenPtr; 545 const char **nextSubKeyPtr; 546{ 547 char *keySeparPtr; 548 int keyLen, findIdx; 549 550 keySeparPtr = strchr (key, '.'); 551 if (keySeparPtr != NULL) { 552 keyLen = keySeparPtr - key; 553 } else { 554 keyLen = strlen (key); 555 } 556 557 for (findIdx = 0; findIdx < keylIntPtr->numEntries; findIdx++) { 558 if ((strncmp (keylIntPtr->entries [findIdx].key, key, keyLen) == 0) && 559 (keylIntPtr->entries [findIdx].key [keyLen] == '\0')) 560 break; 561 } 562 563 if (nextSubKeyPtr != NULL) { 564 if (keySeparPtr == NULL) { 565 *nextSubKeyPtr = NULL; 566 } else { 567 *nextSubKeyPtr = keySeparPtr + 1; 568 } 569 } 570 if (keyLenPtr != NULL) { 571 *keyLenPtr = keyLen; 572 } 573 574 if (findIdx >= keylIntPtr->numEntries) { 575 return -1; 576 } 577 578 return findIdx; 579} 580 581/*----------------------------------------------------------------------------- 582 * ObjToKeyedListEntry -- 583 * Convert an object to a keyed list entry. (Keyword/value pair). 584 * 585 * Parameters: 586 * o interp - Used to return error messages, if not NULL. 587 * o objPtr - Object to convert. Each entry must be a two element list, 588 * with the first element being the key and the second being the 589 * value. 590 * o entryPtr - The keyed list entry to initialize from the object. 591 * Returns: 592 * TCL_OK or TCL_ERROR. 593 *----------------------------------------------------------------------------- 594 */ 595static int 596ObjToKeyedListEntry (interp, objPtr, entryPtr) 597 Tcl_Interp *interp; 598 Tcl_Obj *objPtr; 599 keylEntry_t *entryPtr; 600{ 601 int objc; 602 Tcl_Obj **objv; 603 const char *key; 604 int keyLen; 605 606 if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK) { 607 Tcl_ResetResult (interp); 608 Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), 609 "keyed list entry not a valid list, ", 610 "found \"", 611 Tcl_GetStringFromObj (objPtr, NULL), 612 "\"", (char *) NULL); 613 return TCL_ERROR; 614 } 615 616 if (objc != 2) { 617 Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), 618 "keyed list entry must be a two ", 619 "element list, found \"", 620 Tcl_GetStringFromObj (objPtr, NULL), 621 "\"", (char *) NULL); 622 return TCL_ERROR; 623 } 624 625 key = Tcl_GetStringFromObj (objv [0], &keyLen); 626 if (ValidateKey (interp, key, keyLen, FALSE) == TCL_ERROR) { 627 return TCL_ERROR; 628 } 629 630 entryPtr->key = ckstrdup (key); 631 entryPtr->valuePtr = Tcl_DuplicateObj (objv [1]); 632 Tcl_IncrRefCount (entryPtr->valuePtr); 633 634 return TCL_OK; 635} 636 637/*----------------------------------------------------------------------------- 638 * FreeKeyedListInternalRep -- 639 * Free the internal representation of a keyed list. 640 * 641 * Parameters: 642 * o keylPtr - Keyed list object being deleted. 643 *----------------------------------------------------------------------------- 644 */ 645static void 646FreeKeyedListInternalRep (keylPtr) 647 Tcl_Obj *keylPtr; 648{ 649 FreeKeyedListData ((keylIntObj_t *) keylPtr->internalRep.otherValuePtr); 650} 651 652/*----------------------------------------------------------------------------- 653 * DupKeyedListInternalRep -- 654 * Duplicate the internal representation of a keyed list. 655 * 656 * Parameters: 657 * o srcPtr - Keyed list object to copy. 658 * o copyPtr - Target object to copy internal representation to. 659 *----------------------------------------------------------------------------- 660 */ 661static void 662DupKeyedListInternalRep (srcPtr, copyPtr) 663 Tcl_Obj *srcPtr; 664 Tcl_Obj *copyPtr; 665{ 666 keylIntObj_t *srcIntPtr = 667 (keylIntObj_t *) srcPtr->internalRep.otherValuePtr; 668 keylIntObj_t *copyIntPtr; 669 int idx; 670 671 KEYL_REP_ASSERT (srcIntPtr); 672 673 copyIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t)); 674 copyIntPtr->arraySize = srcIntPtr->arraySize; 675 copyIntPtr->numEntries = srcIntPtr->numEntries; 676 copyIntPtr->entries = (keylEntry_t *) 677 ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t)); 678 679 for (idx = 0; idx < srcIntPtr->numEntries ; idx++) { 680 copyIntPtr->entries [idx].key = 681 ckstrdup (srcIntPtr->entries [idx].key); 682 copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr; 683 Tcl_IncrRefCount (copyIntPtr->entries [idx].valuePtr); 684 } 685 686 copyPtr->internalRep.otherValuePtr = (VOID *) copyIntPtr; 687 copyPtr->typePtr = &keyedListType; 688 689 KEYL_REP_ASSERT (copyIntPtr); 690} 691 692/*----------------------------------------------------------------------------- 693 * DupKeyedListInternalRepShared -- 694 * Same as DupKeyedListInternalRepbut does not reference objects 695 * from the srcPtr list. It duplicates them and stores the copy 696 * in the list-copy object. 697 * 698 * Parameters: 699 * o srcPtr - Keyed list object to copy. 700 * o copyPtr - Target object to copy internal representation to. 701 *----------------------------------------------------------------------------- 702 */ 703void 704DupKeyedListInternalRepShared (srcPtr, copyPtr) 705 Tcl_Obj *srcPtr; 706 Tcl_Obj *copyPtr; 707{ 708 keylIntObj_t *srcIntPtr = 709 (keylIntObj_t *) srcPtr->internalRep.otherValuePtr; 710 keylIntObj_t *copyIntPtr; 711 int idx; 712 713 KEYL_REP_ASSERT (srcIntPtr); 714 715 copyIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t)); 716 copyIntPtr->arraySize = srcIntPtr->arraySize; 717 copyIntPtr->numEntries = srcIntPtr->numEntries; 718 copyIntPtr->entries = (keylEntry_t *) 719 ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t)); 720 721 for (idx = 0; idx < srcIntPtr->numEntries ; idx++) { 722 copyIntPtr->entries [idx].key = 723 ckstrdup (srcIntPtr->entries [idx].key); 724 copyIntPtr->entries [idx].valuePtr = 725 Sv_DuplicateObj (srcIntPtr->entries [idx].valuePtr); 726 Tcl_IncrRefCount(copyIntPtr->entries [idx].valuePtr); 727 } 728 729 copyPtr->internalRep.otherValuePtr = (VOID *) copyIntPtr; 730 copyPtr->typePtr = &keyedListType; 731 732 KEYL_REP_ASSERT (copyIntPtr); 733} 734 735/*----------------------------------------------------------------------------- 736 * SetKeyedListFromAny -- 737 * Convert an object to a keyed list from its string representation. Only 738 * the first level is converted, as there is no way of knowing how far down 739 * the keyed list recurses until lower levels are accessed. 740 * 741 * Parameters: 742 * o objPtr - Object to convert to a keyed list. 743 *----------------------------------------------------------------------------- 744 */ 745static int 746SetKeyedListFromAny (interp, objPtr) 747 Tcl_Interp *interp; 748 Tcl_Obj *objPtr; 749{ 750 keylIntObj_t *keylIntPtr; 751 int idx, objc; 752 Tcl_Obj **objv; 753 754 if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK) 755 return TCL_ERROR; 756 757 keylIntPtr = AllocKeyedListIntRep (); 758 759 EnsureKeyedListSpace (keylIntPtr, objc); 760 761 for (idx = 0; idx < objc; idx++) { 762 if (ObjToKeyedListEntry (interp, objv [idx], 763 &(keylIntPtr->entries [keylIntPtr->numEntries])) != TCL_OK) 764 goto errorExit; 765 keylIntPtr->numEntries++; 766 } 767 768 if ((objPtr->typePtr != NULL) && 769 (objPtr->typePtr->freeIntRepProc != NULL)) { 770 (*objPtr->typePtr->freeIntRepProc) (objPtr); 771 } 772 objPtr->internalRep.otherValuePtr = (VOID *) keylIntPtr; 773 objPtr->typePtr = &keyedListType; 774 775 KEYL_REP_ASSERT (keylIntPtr); 776 return TCL_OK; 777 778 errorExit: 779 FreeKeyedListData (keylIntPtr); 780 return TCL_ERROR; 781} 782 783/*----------------------------------------------------------------------------- 784 * UpdateStringOfKeyedList -- 785 * Update the string representation of a keyed list. 786 * 787 * Parameters: 788 * o objPtr - Object to convert to a keyed list. 789 *----------------------------------------------------------------------------- 790 */ 791static void 792UpdateStringOfKeyedList (keylPtr) 793 Tcl_Obj *keylPtr; 794{ 795#define UPDATE_STATIC_SIZE 32 796 int idx, strLen; 797 Tcl_Obj **listObjv, *entryObjv [2], *tmpListObj; 798 Tcl_Obj *staticListObjv [UPDATE_STATIC_SIZE]; 799 char *listStr; 800 keylIntObj_t *keylIntPtr = 801 (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; 802 803 /* 804 * Conversion to strings is done via list objects to support binary data. 805 */ 806 if (keylIntPtr->numEntries > UPDATE_STATIC_SIZE) { 807 listObjv = 808 (Tcl_Obj **) ckalloc (keylIntPtr->numEntries * sizeof (Tcl_Obj *)); 809 } else { 810 listObjv = staticListObjv; 811 } 812 813 /* 814 * Convert each keyed list entry to a two element list object. No 815 * need to incr/decr ref counts, the list objects will take care of that. 816 * FIX: Keeping key as string object will speed this up. 817 */ 818 for (idx = 0; idx < keylIntPtr->numEntries; idx++) { 819 entryObjv [0] = 820 Tcl_NewStringObj (keylIntPtr->entries [idx].key, 821 strlen (keylIntPtr->entries [idx].key)); 822 entryObjv [1] = keylIntPtr->entries [idx].valuePtr; 823 listObjv [idx] = Tcl_NewListObj (2, entryObjv); 824 } 825 826 tmpListObj = Tcl_NewListObj (keylIntPtr->numEntries, listObjv); 827 listStr = Tcl_GetStringFromObj (tmpListObj, &strLen); 828 keylPtr->bytes = ckbinstrdup (listStr, strLen); 829 keylPtr->length = strLen; 830 831 Tcl_DecrRefCount (tmpListObj); 832 if (listObjv != staticListObjv) 833 ckfree ((VOID*) listObjv); 834} 835 836/*----------------------------------------------------------------------------- 837 * TclX_NewKeyedListObj -- 838 * Create and initialize a new keyed list object. 839 * 840 * Returns: 841 * A pointer to the object. 842 *----------------------------------------------------------------------------- 843 */ 844Tcl_Obj * 845TclX_NewKeyedListObj () 846{ 847 Tcl_Obj *keylPtr = Tcl_NewObj (); 848 keylIntObj_t *keylIntPtr = AllocKeyedListIntRep (); 849 850 keylPtr->internalRep.otherValuePtr = (VOID *) keylIntPtr; 851 keylPtr->typePtr = &keyedListType; 852 return keylPtr; 853} 854 855/*----------------------------------------------------------------------------- 856 * TclX_KeyedListGet -- 857 * Retrieve a key value from a keyed list. 858 * 859 * Parameters: 860 * o interp - Error message will be return in result if there is an error. 861 * o keylPtr - Keyed list object to get key from. 862 * o key - The name of the key to extract. Will recusively process sub-keys 863 * seperated by `.'. 864 * o valueObjPtrPtr - If the key is found, a pointer to the key object 865 * is returned here. NULL is returned if the key is not present. 866 * Returns: 867 * o TCL_OK - If the key value was returned. 868 * o TCL_BREAK - If the key was not found. 869 * o TCL_ERROR - If an error occured. 870 *----------------------------------------------------------------------------- 871 */ 872int 873TclX_KeyedListGet (interp, keylPtr, key, valuePtrPtr) 874 Tcl_Interp *interp; 875 Tcl_Obj *keylPtr; 876 const char *key; 877 Tcl_Obj **valuePtrPtr; 878{ 879 keylIntObj_t *keylIntPtr; 880 const char *nextSubKey; 881 int findIdx; 882 883 if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) 884 return TCL_ERROR; 885 keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; 886 KEYL_REP_ASSERT (keylIntPtr); 887 888 findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); 889 890 /* 891 * If not found, return status. 892 */ 893 if (findIdx < 0) { 894 *valuePtrPtr = NULL; 895 return TCL_BREAK; 896 } 897 898 /* 899 * If we are at the last subkey, return the entry, otherwise recurse 900 * down looking for the entry. 901 */ 902 if (nextSubKey == NULL) { 903 *valuePtrPtr = keylIntPtr->entries [findIdx].valuePtr; 904 return TCL_OK; 905 } else { 906 return TclX_KeyedListGet (interp, 907 keylIntPtr->entries [findIdx].valuePtr, 908 nextSubKey, 909 valuePtrPtr); 910 } 911} 912 913/*----------------------------------------------------------------------------- 914 * TclX_KeyedListSet -- 915 * Set a key value in keyed list object. 916 * 917 * Parameters: 918 * o interp - Error message will be return in result object. 919 * o keylPtr - Keyed list object to update. 920 * o key - The name of the key to extract. Will recusively process 921 * sub-key seperated by `.'. 922 * o valueObjPtr - The value to set for the key. 923 * Returns: 924 * TCL_OK or TCL_ERROR. 925 *----------------------------------------------------------------------------- 926 */ 927int 928TclX_KeyedListSet (interp, keylPtr, key, valuePtr) 929 Tcl_Interp *interp; 930 Tcl_Obj *keylPtr; 931 const char *key; 932 Tcl_Obj *valuePtr; 933{ 934 keylIntObj_t *keylIntPtr; 935 const char *nextSubKey; 936 int findIdx, keyLen, status; 937 Tcl_Obj *newKeylPtr; 938 939 if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) 940 return TCL_ERROR; 941 keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; 942 KEYL_REP_ASSERT (keylIntPtr); 943 944 findIdx = FindKeyedListEntry (keylIntPtr, key, 945 &keyLen, &nextSubKey); 946 947 /* 948 * If we are at the last subkey, either update or add an entry. 949 */ 950 if (nextSubKey == NULL) { 951 if (findIdx < 0) { 952 EnsureKeyedListSpace (keylIntPtr, 1); 953 findIdx = keylIntPtr->numEntries; 954 keylIntPtr->numEntries++; 955 } else { 956 ckfree (keylIntPtr->entries [findIdx].key); 957 Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr); 958 } 959 keylIntPtr->entries [findIdx].key = 960 (char *) ckalloc (keyLen + 1); 961 strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); 962 keylIntPtr->entries [findIdx].key [keyLen] = '\0'; 963 keylIntPtr->entries [findIdx].valuePtr = valuePtr; 964 Tcl_IncrRefCount (valuePtr); 965 Tcl_InvalidateStringRep (keylPtr); 966 967 KEYL_REP_ASSERT (keylIntPtr); 968 return TCL_OK; 969 } 970 971 /* 972 * If we are not at the last subkey, recurse down, creating new 973 * entries if neccessary. If this level key was not found, it 974 * means we must build new subtree. Don't insert the new tree until we 975 * come back without error. 976 */ 977 if (findIdx >= 0) { 978 DupSharedKeyListChild (keylIntPtr, findIdx); 979 status = 980 TclX_KeyedListSet (interp, 981 keylIntPtr->entries [findIdx].valuePtr, 982 nextSubKey, valuePtr); 983 if (status == TCL_OK) { 984 Tcl_InvalidateStringRep (keylPtr); 985 } 986 987 KEYL_REP_ASSERT (keylIntPtr); 988 return status; 989 } else { 990 newKeylPtr = TclX_NewKeyedListObj (); 991 if (TclX_KeyedListSet (interp, newKeylPtr, 992 nextSubKey, valuePtr) != TCL_OK) { 993 Tcl_DecrRefCount (newKeylPtr); 994 return TCL_ERROR; 995 } 996 EnsureKeyedListSpace (keylIntPtr, 1); 997 findIdx = keylIntPtr->numEntries++; 998 keylIntPtr->entries [findIdx].key = 999 (char *) ckalloc (keyLen + 1); 1000 strncpy (keylIntPtr->entries [findIdx].key, key, keyLen); 1001 keylIntPtr->entries [findIdx].key [keyLen] = '\0'; 1002 keylIntPtr->entries [findIdx].valuePtr = newKeylPtr; 1003 Tcl_IncrRefCount (newKeylPtr); 1004 Tcl_InvalidateStringRep (keylPtr); 1005 1006 KEYL_REP_ASSERT (keylIntPtr); 1007 return TCL_OK; 1008 } 1009} 1010 1011/*----------------------------------------------------------------------------- 1012 * TclX_KeyedListDelete -- 1013 * Delete a key value from keyed list. 1014 * 1015 * Parameters: 1016 * o interp - Error message will be return in result if there is an error. 1017 * o keylPtr - Keyed list object to update. 1018 * o key - The name of the key to extract. Will recusively process 1019 * sub-key seperated by `.'. 1020 * Returns: 1021 * o TCL_OK - If the key was deleted. 1022 * o TCL_BREAK - If the key was not found. 1023 * o TCL_ERROR - If an error occured. 1024 *----------------------------------------------------------------------------- 1025 */ 1026int 1027TclX_KeyedListDelete (interp, keylPtr, key) 1028 Tcl_Interp *interp; 1029 Tcl_Obj *keylPtr; 1030 const char *key; 1031{ 1032 keylIntObj_t *keylIntPtr, *subKeylIntPtr; 1033 const char *nextSubKey; 1034 int findIdx, status; 1035 1036 if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) 1037 return TCL_ERROR; 1038 keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; 1039 1040 findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); 1041 1042 /* 1043 * If not found, return status. 1044 */ 1045 if (findIdx < 0) { 1046 KEYL_REP_ASSERT (keylIntPtr); 1047 return TCL_BREAK; 1048 } 1049 1050 /* 1051 * If we are at the last subkey, delete the entry. 1052 */ 1053 if (nextSubKey == NULL) { 1054 DeleteKeyedListEntry (keylIntPtr, findIdx); 1055 Tcl_InvalidateStringRep (keylPtr); 1056 1057 KEYL_REP_ASSERT (keylIntPtr); 1058 return TCL_OK; 1059 } 1060 1061 /* 1062 * If we are not at the last subkey, recurse down. If the entry is 1063 * deleted and the sub-keyed list is empty, delete it as well. Must 1064 * invalidate string, as it caches all representations below it. 1065 */ 1066 DupSharedKeyListChild (keylIntPtr, findIdx); 1067 1068 status = TclX_KeyedListDelete (interp, 1069 keylIntPtr->entries [findIdx].valuePtr, 1070 nextSubKey); 1071 if (status == TCL_OK) { 1072 subKeylIntPtr = (keylIntObj_t *) 1073 keylIntPtr->entries [findIdx].valuePtr->internalRep.otherValuePtr; 1074 if (subKeylIntPtr->numEntries == 0) { 1075 DeleteKeyedListEntry (keylIntPtr, findIdx); 1076 } 1077 Tcl_InvalidateStringRep (keylPtr); 1078 } 1079 1080 KEYL_REP_ASSERT (keylIntPtr); 1081 return status; 1082} 1083 1084/*----------------------------------------------------------------------------- 1085 * TclX_KeyedListGetKeys -- 1086 * Retrieve a list of keyed list keys. 1087 * 1088 * Parameters: 1089 * o interp - Error message will be return in result if there is an error. 1090 * o keylPtr - Keyed list object to get key from. 1091 * o key - The name of the key to get the sub keys for. NULL or empty 1092 * to retrieve all top level keys. 1093 * o listObjPtrPtr - List object is returned here with key as values. 1094 * Returns: 1095 * o TCL_OK - If the zero or more key where returned. 1096 * o TCL_BREAK - If the key was not found. 1097 * o TCL_ERROR - If an error occured. 1098 *----------------------------------------------------------------------------- 1099 */ 1100int 1101TclX_KeyedListGetKeys (interp, keylPtr, key, listObjPtrPtr) 1102 Tcl_Interp *interp; 1103 Tcl_Obj *keylPtr; 1104 const char *key; 1105 Tcl_Obj **listObjPtrPtr; 1106{ 1107 keylIntObj_t *keylIntPtr; 1108 Tcl_Obj *nameObjPtr, *listObjPtr; 1109 const char *nextSubKey; 1110 int idx, findIdx; 1111 1112 if (Tcl_ConvertToType (interp, keylPtr, &keyedListType) != TCL_OK) 1113 return TCL_ERROR; 1114 keylIntPtr = (keylIntObj_t *) keylPtr->internalRep.otherValuePtr; 1115 1116 /* 1117 * If key is not NULL or empty, then recurse down until we go past 1118 * the end of all of the elements of the key. 1119 */ 1120 if ((key != NULL) && (key [0] != '\0')) { 1121 findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey); 1122 if (findIdx < 0) { 1123 TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); 1124 return TCL_BREAK; 1125 } 1126 TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); 1127 return TclX_KeyedListGetKeys (interp, 1128 keylIntPtr->entries [findIdx].valuePtr, 1129 nextSubKey, 1130 listObjPtrPtr); 1131 } 1132 1133 /* 1134 * Reached the end of the full key, return all keys at this level. 1135 */ 1136 listObjPtr = Tcl_NewListObj (0, NULL); 1137 for (idx = 0; idx < keylIntPtr->numEntries; idx++) { 1138 nameObjPtr = Tcl_NewStringObj (keylIntPtr->entries [idx].key, 1139 -1); 1140 if (Tcl_ListObjAppendElement (interp, listObjPtr, 1141 nameObjPtr) != TCL_OK) { 1142 Tcl_DecrRefCount (nameObjPtr); 1143 Tcl_DecrRefCount (listObjPtr); 1144 return TCL_ERROR; 1145 } 1146 } 1147 *listObjPtrPtr = listObjPtr; 1148 TclX_Assert (keylIntPtr->arraySize >= keylIntPtr->numEntries); 1149 return TCL_OK; 1150} 1151 1152/*----------------------------------------------------------------------------- 1153 * Tcl_KeylgetObjCmd -- 1154 * Implements the TCL keylget command: 1155 * keylget listvar ?key? ?retvar | {}? 1156 *----------------------------------------------------------------------------- 1157 */ 1158static int 1159Tcl_KeylgetObjCmd (clientData, interp, objc, objv) 1160 ClientData clientData; 1161 Tcl_Interp *interp; 1162 int objc; 1163 Tcl_Obj *const objv[]; 1164{ 1165 Tcl_Obj *keylPtr, *valuePtr; 1166 const char *varName, *key; 1167 int keyLen, status; 1168 1169 if ((objc < 2) || (objc > 4)) { 1170 return TclX_WrongArgs (interp, objv [0], 1171 "listvar ?key? ?retvar | {}?"); 1172 } 1173 varName = Tcl_GetStringFromObj (objv [1], NULL); 1174 1175 /* 1176 * Handle request for list of keys, use keylkeys command. 1177 */ 1178 if (objc == 2) 1179 return Tcl_KeylkeysObjCmd (clientData, interp, objc, objv); 1180 1181 keylPtr = Tcl_GetVar2Ex(interp, varName, NULL, 1182 TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); 1183 if (keylPtr == NULL) { 1184 return TCL_ERROR; 1185 } 1186 1187 /* 1188 * Handle retrieving a value for a specified key. 1189 */ 1190 key = Tcl_GetStringFromObj (objv [2], &keyLen); 1191 if (ValidateKey (interp, key, keyLen, TRUE) == TCL_ERROR) { 1192 return TCL_ERROR; 1193 } 1194 1195 status = TclX_KeyedListGet (interp, keylPtr, key, &valuePtr); 1196 if (status == TCL_ERROR) 1197 return TCL_ERROR; 1198 1199 /* 1200 * Handle key not found. 1201 */ 1202 if (status == TCL_BREAK) { 1203 if (objc == 3) { 1204 TclX_AppendObjResult (interp, "key \"", key, 1205 "\" not found in keyed list", 1206 (char *) NULL); 1207 return TCL_ERROR; 1208 } else { 1209 Tcl_ResetResult(interp); 1210 Tcl_SetBooleanObj (Tcl_GetObjResult (interp), FALSE); 1211 return TCL_OK; 1212 } 1213 } 1214 1215 /* 1216 * No variable specified, so return value in the result. 1217 */ 1218 if (objc == 3) { 1219 Tcl_SetObjResult (interp, valuePtr); 1220 return TCL_OK; 1221 } 1222 1223 /* 1224 * Variable (or empty variable name) specified. 1225 */ 1226 if (!TclX_IsNullObj (objv [3])) { 1227 if (Tcl_SetVar2Ex(interp, Tcl_GetStringFromObj(objv [3], NULL), NULL, 1228 valuePtr, TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) 1229 return TCL_ERROR; 1230 } 1231 Tcl_ResetResult(interp); 1232 Tcl_SetBooleanObj (Tcl_GetObjResult (interp), TRUE); 1233 return TCL_OK; 1234} 1235 1236/*----------------------------------------------------------------------------- 1237 * Tcl_KeylsetObjCmd -- 1238 * Implements the TCL keylset command: 1239 * keylset listvar key value ?key value...? 1240 *----------------------------------------------------------------------------- 1241 */ 1242static int 1243Tcl_KeylsetObjCmd (clientData, interp, objc, objv) 1244 ClientData clientData; 1245 Tcl_Interp *interp; 1246 int objc; 1247 Tcl_Obj *const objv[]; 1248{ 1249 Tcl_Obj *keylVarPtr, *newVarObj; 1250 const char *varName, *key; 1251 int idx, keyLen; 1252 1253 if ((objc < 4) || ((objc % 2) != 0)) { 1254 return TclX_WrongArgs (interp, objv [0], 1255 "listvar key value ?key value...?"); 1256 } 1257 varName = Tcl_GetStringFromObj (objv [1], NULL); 1258 1259 /* 1260 * Get the variable that we are going to update. If the var doesn't exist, 1261 * create it. If it is shared by more than being a variable, duplicated 1262 * it. 1263 */ 1264 keylVarPtr = Tcl_GetVar2Ex(interp, varName, NULL, TCL_PARSE_PART1); 1265 if ((keylVarPtr == NULL) || (Tcl_IsShared (keylVarPtr))) { 1266 if (keylVarPtr == NULL) { 1267 keylVarPtr = TclX_NewKeyedListObj (); 1268 } else { 1269 keylVarPtr = Tcl_DuplicateObj (keylVarPtr); 1270 } 1271 newVarObj = keylVarPtr; 1272 } else { 1273 newVarObj = NULL; 1274 } 1275 1276 for (idx = 2; idx < objc; idx += 2) { 1277 key = Tcl_GetStringFromObj (objv [idx], &keyLen); 1278 if (ValidateKey (interp, key, keyLen, TRUE) == TCL_ERROR) { 1279 goto errorExit; 1280 } 1281 if (TclX_KeyedListSet (interp, keylVarPtr, key, objv [idx+1]) != TCL_OK) { 1282 goto errorExit; 1283 } 1284 } 1285 1286 if (Tcl_SetVar2Ex(interp, varName, NULL, keylVarPtr, 1287 TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG) == NULL) { 1288 goto errorExit; 1289 } 1290 1291 return TCL_OK; 1292 1293 errorExit: 1294 if (newVarObj != NULL) { 1295 Tcl_DecrRefCount (newVarObj); 1296 } 1297 return TCL_ERROR; 1298} 1299 1300/*----------------------------------------------------------------------------- 1301 * Tcl_KeyldelObjCmd -- 1302 * Implements the TCL keyldel command: 1303 * keyldel listvar key ?key ...? 1304 *---------------------------------------------------------------------------- 1305 */ 1306static int 1307Tcl_KeyldelObjCmd (clientData, interp, objc, objv) 1308 ClientData clientData; 1309 Tcl_Interp *interp; 1310 int objc; 1311 Tcl_Obj *const objv[]; 1312{ 1313 Tcl_Obj *keylVarPtr, *keylPtr; 1314 const char *varName, *key; 1315 int idx, keyLen, status; 1316 1317 if (objc < 3) { 1318 return TclX_WrongArgs (interp, objv [0], "listvar key ?key ...?"); 1319 } 1320 varName = Tcl_GetStringFromObj (objv [1], NULL); 1321 1322 /* 1323 * Get the variable that we are going to update. If it is shared by more 1324 * than being a variable, duplicated it. 1325 */ 1326 keylVarPtr = Tcl_GetVar2Ex(interp, varName, NULL, 1327 TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); 1328 if (keylVarPtr == NULL) { 1329 return TCL_ERROR; 1330 } 1331 if (Tcl_IsShared (keylVarPtr)) { 1332 keylPtr = Tcl_DuplicateObj (keylVarPtr); 1333 keylVarPtr = Tcl_SetVar2Ex(interp, varName, NULL, keylPtr, 1334 TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); 1335 if (keylVarPtr == NULL) { 1336 Tcl_DecrRefCount (keylPtr); 1337 return TCL_ERROR; 1338 } 1339 if (keylVarPtr != keylPtr) { 1340 Tcl_DecrRefCount (keylPtr); 1341 } 1342 } 1343 keylPtr = keylVarPtr; 1344 1345 for (idx = 2; idx < objc; idx++) { 1346 key = Tcl_GetStringFromObj (objv [idx], &keyLen); 1347 if (ValidateKey (interp, key, keyLen, TRUE) == TCL_ERROR) { 1348 return TCL_ERROR; 1349 } 1350 1351 status = TclX_KeyedListDelete (interp, keylPtr, key); 1352 switch (status) { 1353 case TCL_BREAK: 1354 TclX_AppendObjResult (interp, "key not found: \"", 1355 key, "\"", (char *) NULL); 1356 return TCL_ERROR; 1357 case TCL_ERROR: 1358 return TCL_ERROR; 1359 } 1360 } 1361 1362 return TCL_OK; 1363} 1364 1365/*----------------------------------------------------------------------------- 1366 * Tcl_KeylkeysObjCmd -- 1367 * Implements the TCL keylkeys command: 1368 * keylkeys listvar ?key? 1369 *----------------------------------------------------------------------------- 1370 */ 1371static int 1372Tcl_KeylkeysObjCmd (clientData, interp, objc, objv) 1373 ClientData clientData; 1374 Tcl_Interp *interp; 1375 int objc; 1376 Tcl_Obj *const objv[]; 1377{ 1378 Tcl_Obj *keylPtr, *listObjPtr; 1379 const char *varName, *key; 1380 int keyLen, status; 1381 1382 if ((objc < 2) || (objc > 3)) { 1383 return TclX_WrongArgs (interp, objv [0], "listvar ?key?"); 1384 } 1385 varName = Tcl_GetStringFromObj (objv [1], NULL); 1386 1387 keylPtr = Tcl_GetVar2Ex(interp, varName, NULL, 1388 TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); 1389 if (keylPtr == NULL) { 1390 return TCL_ERROR; 1391 } 1392 1393 /* 1394 * If key argument is not specified, then objv [2] is NULL or empty, 1395 * meaning get top level keys. 1396 */ 1397 if (objc < 3) { 1398 key = NULL; 1399 } else { 1400 key = Tcl_GetStringFromObj (objv [2], &keyLen); 1401 if (ValidateKey (interp, key, keyLen, TRUE) == TCL_ERROR) { 1402 return TCL_ERROR; 1403 } 1404 } 1405 1406 status = TclX_KeyedListGetKeys (interp, keylPtr, key, &listObjPtr); 1407 switch (status) { 1408 case TCL_BREAK: 1409 TclX_AppendObjResult (interp, "key not found: \"", key, "\"", 1410 (char *) NULL); 1411 return TCL_ERROR; 1412 case TCL_ERROR: 1413 return TCL_ERROR; 1414 } 1415 1416 Tcl_SetObjResult (interp, listObjPtr); 1417 1418 return TCL_OK; 1419} 1420 1421/*----------------------------------------------------------------------------- 1422 * TclX_KeyedListInit -- 1423 * Initialize the keyed list commands for this interpreter. 1424 * 1425 * Parameters: 1426 * o interp - Interpreter to add commands to. 1427 *----------------------------------------------------------------------------- 1428 */ 1429void 1430TclX_KeyedListInit (interp) 1431 Tcl_Interp *interp; 1432{ 1433 Tcl_RegisterObjType (&keyedListType); 1434 1435 listType = Tcl_GetObjType("list"); 1436 stringType = Tcl_GetObjType("string"); 1437 1438 if (0) { 1439 Tcl_CreateObjCommand (interp, 1440 "keylget", 1441 Tcl_KeylgetObjCmd, 1442 (ClientData) NULL, 1443 (Tcl_CmdDeleteProc*) NULL); 1444 1445 Tcl_CreateObjCommand (interp, 1446 "keylset", 1447 Tcl_KeylsetObjCmd, 1448 (ClientData) NULL, 1449 (Tcl_CmdDeleteProc*) NULL); 1450 1451 Tcl_CreateObjCommand (interp, 1452 "keyldel", 1453 Tcl_KeyldelObjCmd, 1454 (ClientData) NULL, 1455 (Tcl_CmdDeleteProc*) NULL); 1456 1457 Tcl_CreateObjCommand (interp, 1458 "keylkeys", 1459 Tcl_KeylkeysObjCmd, 1460 (ClientData) NULL, 1461 (Tcl_CmdDeleteProc*) NULL); 1462 } 1463} 1464 1465 1466