1/*
2 * threadSvKeylist.c --
3 *
4 * This file implements keyed-list commands as part of the thread
5 * shared variable implementation.
6 *
7 * Keyed list implementation is borrowed from Mark Diekhans and
8 * Karl Lehenbauer "TclX" (extended Tcl) extension. Please look
9 * into the keylist.c file for more information.
10 *
11 * See the file "license.txt" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * Rcsid: @(#)$Id: threadSvKeylistCmd.c,v 1.3 2009/07/22 11:25:34 nijtmans Exp $
15 * ---------------------------------------------------------------------------
16 */
17
18#include "threadSvCmd.h"
19#include "tclXkeylist.h"
20
21/*
22 * This is defined in keylist.c. We need it here
23 * to be able to plug-in our custom keyed-list
24 * object duplicator which produces proper deep
25 * copies of the keyed-list objects. The standard
26 * one produces shallow copies which are not good
27 * for usage in the thread shared variables code.
28 */
29
30extern Tcl_ObjType keyedListType;
31
32/*
33 * Wrapped keyed-list commands
34 */
35
36static Tcl_ObjCmdProc SvKeylsetObjCmd;
37static Tcl_ObjCmdProc SvKeylgetObjCmd;
38static Tcl_ObjCmdProc SvKeyldelObjCmd;
39static Tcl_ObjCmdProc SvKeylkeysObjCmd;
40
41/*
42 * This mutex protects a static variable which tracks
43 * registration of commands and object types.
44 */
45
46static Tcl_Mutex initMutex;
47
48
49/*
50 *-----------------------------------------------------------------------------
51 *
52 * Sv_RegisterKeylistCommands --
53 *
54 *      Register shared variable commands for TclX keyed lists.
55 *
56 * Results:
57 *      A standard Tcl result.
58 *
59 * Side effects:
60 *      Memory gets allocated
61 *
62 *-----------------------------------------------------------------------------
63 */
64void
65Sv_RegisterKeylistCommands(void)
66{
67    static int initialized;
68
69    if (initialized == 0) {
70        Tcl_MutexLock(&initMutex);
71        if (initialized == 0) {
72            Sv_RegisterCommand("keylset",  SvKeylsetObjCmd,  NULL, NULL);
73            Sv_RegisterCommand("keylget",  SvKeylgetObjCmd,  NULL, NULL);
74            Sv_RegisterCommand("keyldel",  SvKeyldelObjCmd,  NULL, NULL);
75            Sv_RegisterCommand("keylkeys", SvKeylkeysObjCmd, NULL, NULL);
76            Sv_RegisterObjType(&keyedListType, DupKeyedListInternalRepShared);
77            initialized = 1;
78        }
79        Tcl_MutexUnlock(&initMutex);
80    }
81}
82
83/*
84 *-----------------------------------------------------------------------------
85 *
86 * SvKeylsetObjCmd --
87 *
88 *      This procedure is invoked to process the "tsv::keylset" command.
89 *      See the user documentation for details on what it does.
90 *
91 * Results:
92 *      A standard Tcl result.
93 *
94 * Side effects:
95 *      See the user documentation.
96 *
97 *-----------------------------------------------------------------------------
98 */
99
100static int
101SvKeylsetObjCmd(arg, interp, objc, objv)
102    ClientData arg;                     /* Not used. */
103    Tcl_Interp *interp;                 /* Current interpreter. */
104    int objc;                           /* Number of arguments. */
105    Tcl_Obj *const objv[];              /* Argument objects. */
106{
107    int i, off, ret, flg;
108    char *key;
109    Tcl_Obj *val;
110    Container *svObj = (Container*)arg;
111
112    /*
113     * Syntax:
114     *          sv::keylset array lkey key value ?key value ...?
115     *          $keylist keylset key value ?key value ...?
116     */
117
118    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
119    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
120    if (ret != TCL_OK) {
121        return TCL_ERROR;
122    }
123    if ((objc - off) < 2 || ((objc - off) % 2)) {
124        Tcl_WrongNumArgs(interp, off, objv, "key value ?key value ...?");
125        goto cmd_err;
126    }
127    for (i = off; i < objc; i += 2) {
128        key = Tcl_GetString(objv[i]);
129        val = Sv_DuplicateObj(objv[i+1]);
130        ret = TclX_KeyedListSet(interp, svObj->tclObj, key, val);
131        if (ret != TCL_OK) {
132            goto cmd_err;
133        }
134    }
135
136    return Sv_PutContainer(interp, svObj, SV_CHANGED);
137
138 cmd_err:
139    return Sv_PutContainer(interp, svObj, SV_ERROR);
140}
141
142/*
143 *-----------------------------------------------------------------------------
144 *
145 * SvKeylgetObjCmd --
146 *
147 *      This procedure is invoked to process the "tsv::keylget" command.
148 *      See the user documentation for details on what it does.
149 *
150 * Results:
151 *      A standard Tcl result.
152 *
153 * Side effects:
154 *      See the user documentation.
155 *
156 *-----------------------------------------------------------------------------
157 */
158
159static int
160SvKeylgetObjCmd(arg, interp, objc, objv)
161    ClientData arg;                     /* Not used. */
162    Tcl_Interp *interp;                 /* Current interpreter. */
163    int objc;                           /* Number of arguments. */
164    Tcl_Obj *const objv[];              /* Argument objects. */
165{
166    int ret, flg, off;
167    char *key;
168    Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL;
169    Container *svObj = (Container*)arg;
170
171    /*
172     * Syntax:
173     *          sv::keylget array lkey ?key? ?var?
174     *          $keylist keylget ?key? ?var?
175     */
176
177    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
178    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
179    if (ret != TCL_OK) {
180        return TCL_ERROR;
181    }
182    if ((objc - off) > 2) {
183        Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?");
184        goto cmd_err;
185    }
186    if ((objc - off) == 0) {
187        if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) {
188            return TCL_ERROR;
189        }
190        return SvKeylkeysObjCmd(arg, interp, objc, objv);
191    }
192    if ((objc - off) == 2) {
193        varObjPtr = objv[off+1];
194    } else {
195        varObjPtr = NULL;
196    }
197
198    key = Tcl_GetString(objv[off]);
199    ret = TclX_KeyedListGet(interp, svObj->tclObj, key, &valObjPtr);
200    if (ret == TCL_ERROR) {
201        goto cmd_err;
202    }
203
204    if (ret == TCL_BREAK) {
205        if (varObjPtr) {
206            Tcl_ResetResult(interp);
207            Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0);
208        } else {
209            Tcl_AppendResult (interp, "key \"", key, "\" not found", NULL);
210            goto cmd_err;
211        }
212    } else {
213        Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr);
214        if (varObjPtr) {
215            int len;
216            Tcl_ResetResult(interp);
217            Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1);
218            Tcl_GetStringFromObj(varObjPtr, &len);
219            if (len) {
220                Tcl_ObjSetVar2(interp, varObjPtr, NULL, resObjPtr, 0);
221            }
222        } else {
223            Tcl_SetObjResult(interp, resObjPtr);
224        }
225    }
226
227    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
228
229 cmd_err:
230    return Sv_PutContainer(interp, svObj, SV_ERROR);
231}
232
233/*
234 *-----------------------------------------------------------------------------
235 *
236 * SvKeyldelObjCmd --
237 *
238 *      This procedure is invoked to process the "tsv::keyldel" command.
239 *      See the user documentation for details on what it does.
240 *
241 * Results:
242 *      A standard Tcl result.
243 *
244 * Side effects:
245 *      See the user documentation.
246 *
247 *-----------------------------------------------------------------------------
248 */
249
250static int
251SvKeyldelObjCmd(arg, interp, objc, objv)
252    ClientData arg;                     /* Not used. */
253    Tcl_Interp *interp;                 /* Current interpreter. */
254    int objc;                           /* Number of arguments. */
255    Tcl_Obj *const objv[];              /* Argument objects. */
256{
257    int i, off, ret;
258    char *key;
259    Container *svObj = (Container*)arg;
260
261    /*
262     * Syntax:
263     *          sv::keyldel array lkey key ?key ...?
264     *          $keylist keyldel ?key ...?
265     */
266
267    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
268    if (ret != TCL_OK) {
269        return TCL_ERROR;
270    }
271    if ((objc - off) < 1) {
272        Tcl_WrongNumArgs(interp, off, objv, "key ?key ...?");
273        goto cmd_err;
274    }
275    for (i = off; i < objc; i++) {
276        key = Tcl_GetString(objv[i]);
277        ret = TclX_KeyedListDelete(interp, svObj->tclObj, key);
278        if (ret == TCL_BREAK) {
279            Tcl_AppendResult(interp, "key \"", key, "\" not found", NULL);
280        }
281        if (ret == TCL_BREAK || ret == TCL_ERROR) {
282            goto cmd_err;
283        }
284    }
285
286    return Sv_PutContainer(interp, svObj, SV_CHANGED);
287
288 cmd_err:
289    return Sv_PutContainer(interp, svObj, SV_ERROR);
290}
291
292/*
293 *-----------------------------------------------------------------------------
294 *
295 * SvKeylkeysObjCmd --
296 *
297 *      This procedure is invoked to process the "tsv::keylkeys" command.
298 *      See the user documentation for details on what it does.
299 *
300 * Results:
301 *      A standard Tcl result.
302 *
303 * Side effects:
304 *      See the user documentation.
305 *
306 *-----------------------------------------------------------------------------
307 */
308
309static int
310SvKeylkeysObjCmd(arg, interp, objc, objv)
311    ClientData arg;                     /* Not used. */
312    Tcl_Interp *interp;                 /* Current interpreter. */
313    int objc;                           /* Number of arguments. */
314    Tcl_Obj *const objv[];              /* Argument objects. */
315{
316    int ret, off;
317    char *key = NULL;
318    Tcl_Obj *listObj = NULL;
319    Container *svObj = (Container*)arg;
320
321    /*
322     * Syntax:
323     *          sv::keylkeys array lkey ?key?
324     *          $keylist keylkeys ?key?
325     */
326
327    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
328    if (ret != TCL_OK) {
329        return TCL_ERROR;
330    }
331    if ((objc - off) > 1) {
332         Tcl_WrongNumArgs(interp, 1, objv, "?lkey?");
333         goto cmd_err;
334    }
335    if ((objc - off) == 1) {
336        key = Tcl_GetString(objv[off]);
337    }
338
339    ret = TclX_KeyedListGetKeys(interp, svObj->tclObj, key, &listObj);
340
341    if (key && ret == TCL_BREAK) {
342        Tcl_AppendResult(interp, "key \"", key, "\" not found", NULL);
343    }
344    if (ret == TCL_BREAK || ret == TCL_ERROR) {
345        goto cmd_err;
346    }
347
348    Tcl_SetObjResult (interp, listObj); /* listObj allocated by API !*/
349
350    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
351
352 cmd_err:
353    return Sv_PutContainer(interp, svObj, SV_ERROR);
354}
355
356/* EOF $RCSfile: threadSvKeylistCmd.c,v $ */
357
358/* Emacs Setup Variables */
359/* Local Variables:      */
360/* mode: C               */
361/* indent-tabs-mode: nil */
362/* c-basic-offset: 4     */
363/* End:                  */
364
365