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