1/*
2 * Implementation of most standard Tcl list processing commands
3 * suitable for operation on thread shared (list) variables.
4 *
5 * Copyright (c) 2002 by Zoran Vasiljevic.
6 *
7 * See the file "license.terms" for information on usage and redistribution
8 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9 *
10 * RCS: @(#) $Id: threadSvListCmd.c,v 1.11 2009/07/22 11:25:34 nijtmans Exp $
11 * ----------------------------------------------------------------------------
12 */
13
14#include "threadSvCmd.h"
15
16/*
17 * Implementation of list commands for shared variables.
18 * Most of the standard Tcl list commands are implemented.
19 * There are also two new commands: "lpop" and "lpush".
20 * Those are very convenient for simple stack operations.
21 *
22 * Main difference to standard Tcl commands is that our commands
23 * operate on list variable per-reference instead per-value.
24 * This way we avoid frequent object shuffling between shared
25 * containers and current interpreter, thus increasing speed.
26 */
27
28static Tcl_ObjCmdProc SvLpopObjCmd;      /* lpop        */
29static Tcl_ObjCmdProc SvLpushObjCmd;     /* lpush       */
30static Tcl_ObjCmdProc SvLappendObjCmd;   /* lappend     */
31static Tcl_ObjCmdProc SvLreplaceObjCmd;  /* lreplace    */
32static Tcl_ObjCmdProc SvLlengthObjCmd;   /* llength     */
33static Tcl_ObjCmdProc SvLindexObjCmd;    /* lindex      */
34static Tcl_ObjCmdProc SvLinsertObjCmd;   /* linsert     */
35static Tcl_ObjCmdProc SvLrangeObjCmd;    /* lrange      */
36static Tcl_ObjCmdProc SvLsearchObjCmd;   /* lsearch     */
37static Tcl_ObjCmdProc SvLsetObjCmd;      /* lset        */
38
39/*
40 * These two are copied verbatim from the tclUtil.c
41 * since not found in the public stubs table.
42 * I was just too lazy to rewrite them from scratch.
43 */
44
45static int SvCheckBadOctal(Tcl_Interp*, const char *);
46static int SvGetIntForIndex(Tcl_Interp*,  Tcl_Obj *, int, int*);
47
48/*
49 * Inefficient list duplicator function which,
50 * however, produces deep list copies, unlike
51 * the original, which just makes shallow copies.
52 */
53
54static void DupListObjShared(Tcl_Obj*, Tcl_Obj*);
55
56/*
57 * This mutex protects a static variable which tracks
58 * registration of commands and object types.
59 */
60
61static Tcl_Mutex initMutex;
62
63/*
64 * Functions for implementing the "lset" list command
65 */
66
67static Tcl_Obj*
68SvLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount,
69           Tcl_Obj **indexArray, Tcl_Obj *valuePtr);
70
71
72/*
73 *-----------------------------------------------------------------------------
74 *
75 * Sv_RegisterListCommands --
76 *
77 *      Register list commands with shared variable module.
78 *
79 * Results:
80 *      A standard Tcl result.
81 *
82 * Side effects:
83 *      Memory gets allocated
84 *
85 *-----------------------------------------------------------------------------
86 */
87
88void
89Sv_RegisterListCommands(void)
90{
91    static int initialized = 0;
92
93    if (initialized == 0) {
94        Tcl_MutexLock(&initMutex);
95        if (initialized == 0) {
96            Sv_RegisterCommand("lpop",     SvLpopObjCmd,     NULL, NULL);
97            Sv_RegisterCommand("lpush",    SvLpushObjCmd,    NULL, NULL);
98            Sv_RegisterCommand("lappend",  SvLappendObjCmd,  NULL, NULL);
99            Sv_RegisterCommand("lreplace", SvLreplaceObjCmd, NULL, NULL);
100            Sv_RegisterCommand("linsert",  SvLinsertObjCmd,  NULL, NULL);
101            Sv_RegisterCommand("llength",  SvLlengthObjCmd,  NULL, NULL);
102            Sv_RegisterCommand("lindex",   SvLindexObjCmd,   NULL, NULL);
103            Sv_RegisterCommand("lrange",   SvLrangeObjCmd,   NULL, NULL);
104            Sv_RegisterCommand("lsearch",  SvLsearchObjCmd,  NULL, NULL);
105            Sv_RegisterCommand("lset",     SvLsetObjCmd,     NULL, NULL);
106            Sv_RegisterObjType(Tcl_GetObjType("list"), DupListObjShared);
107            initialized = 1;
108        }
109        Tcl_MutexUnlock(&initMutex);
110    }
111}
112
113/*
114 *-----------------------------------------------------------------------------
115 *
116 * SvLpopObjCmd --
117 *
118 *      This procedure is invoked to process the "tsv::lpop" command.
119 *      See the user documentation for details on what it does.
120 *
121 * Results:
122 *      A standard Tcl result.
123 *
124 * Side effects:
125 *      See the user documentation.
126 *
127 *-----------------------------------------------------------------------------
128 */
129
130static int
131SvLpopObjCmd (arg, interp, objc, objv)
132    ClientData arg;
133    Tcl_Interp *interp;
134    int objc;
135    Tcl_Obj *const objv[];
136{
137    int ret, off, llen, index = 0, iarg = 0;
138    Tcl_Obj *elPtr = NULL;
139    Container *svObj = (Container*)arg;
140
141    /*
142     * Syntax:
143     *          tsv::lpop array key ?index?
144     *          $list lpop ?index?
145     */
146
147    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
148    if (ret != TCL_OK) {
149        return TCL_ERROR;
150    }
151    if ((objc - off) > 1) {
152        Tcl_WrongNumArgs(interp, off, objv, "?index?");
153        goto cmd_err;
154    }
155    if ((objc - off) == 1) {
156        iarg = off;
157    }
158    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
159    if (ret != TCL_OK) {
160        goto cmd_err;
161    }
162    if (iarg) {
163        ret = SvGetIntForIndex(interp, objv[iarg], llen-1, &index);
164        if (ret != TCL_OK) {
165            goto cmd_err;
166        }
167    }
168    if (index < 0 || index >= llen) {
169        goto cmd_ok; /* Ignore out-of bounds, like Tcl does */
170    }
171    ret = Tcl_ListObjIndex(interp, svObj->tclObj, index, &elPtr);
172    if (ret != TCL_OK) {
173        goto cmd_err;
174    }
175
176    Tcl_IncrRefCount(elPtr);
177    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 1, 0, NULL);
178    if (ret != TCL_OK) {
179        Tcl_DecrRefCount(elPtr);
180        goto cmd_err;
181    }
182    Tcl_SetObjResult(interp, elPtr);
183    Tcl_DecrRefCount(elPtr);
184
185 cmd_ok:
186    return Sv_PutContainer(interp, svObj, SV_CHANGED);
187
188 cmd_err:
189    return Sv_PutContainer(interp, svObj, SV_ERROR);
190}
191
192/*
193 *-----------------------------------------------------------------------------
194 *
195 * SvLpushObjCmd --
196 *
197 *      This procedure is invoked to process the "tsv::lpush" command.
198 *      See the user documentation for details on what it does.
199 *
200 * Results:
201 *      A standard Tcl result.
202 *
203 * Side effects:
204 *      See the user documentation.
205 *
206 *-----------------------------------------------------------------------------
207 */
208
209static int
210SvLpushObjCmd (arg, interp, objc, objv)
211    ClientData arg;
212    Tcl_Interp *interp;
213    int objc;
214    Tcl_Obj *const objv[];
215{
216    int off, ret, flg, llen, index = 0;
217    Tcl_Obj *args[1];
218    Container *svObj = (Container*)arg;
219
220    /*
221     * Syntax:
222     *          tsv::lpush array key element ?index?
223     *          $list lpush element ?index?
224     */
225
226    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
227    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
228    if (ret != TCL_OK) {
229        return TCL_ERROR;
230    }
231    if ((objc - off) < 1) {
232        Tcl_WrongNumArgs(interp, off, objv, "element ?index?");
233        goto cmd_err;
234    }
235    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
236    if (ret != TCL_OK) {
237        goto cmd_err;
238    }
239    if ((objc - off) == 2) {
240        ret = SvGetIntForIndex(interp, objv[off+1], llen, &index);
241        if (ret != TCL_OK) {
242            goto cmd_err;
243        }
244        if (index < 0) {
245            index = 0;
246        } else if (index > llen) {
247            index = llen;
248        }
249    }
250
251    args[0] = Sv_DuplicateObj(objv[off]);
252    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, 1, args);
253    if (ret != TCL_OK) {
254        Tcl_DecrRefCount(args[0]);
255        goto cmd_err;
256    }
257
258    return Sv_PutContainer(interp, svObj, SV_CHANGED);
259
260 cmd_err:
261    return Sv_PutContainer(interp, svObj, SV_ERROR);
262}
263
264/*
265 *-----------------------------------------------------------------------------
266 *
267 * SvLappendObjCmd --
268 *
269 *      This procedure is invoked to process the "tsv::lappend" command.
270 *      See the user documentation for details on what it does.
271 *
272 * Results:
273 *      A standard Tcl result.
274 *
275 * Side effects:
276 *      See the user documentation.
277 *
278 *-----------------------------------------------------------------------------
279 */
280
281static int
282SvLappendObjCmd(arg, interp, objc, objv)
283    ClientData arg;
284    Tcl_Interp *interp;
285    int objc;
286    Tcl_Obj *const objv[];
287{
288    int i, ret, flg, off;
289    Tcl_Obj *dup;
290    Container *svObj = (Container*)arg;
291
292    /*
293     * Syntax:
294     *          tsv::lappend array key value ?value ...?
295     *          $list lappend value ?value ...?
296     */
297
298    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
299    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
300    if (ret != TCL_OK) {
301        return TCL_ERROR;
302    }
303    if ((objc - off) < 1) {
304        Tcl_WrongNumArgs(interp, off, objv, "value ?value ...?");
305        goto cmd_err;
306    }
307    for (i = off; i < objc; i++) {
308        dup = Sv_DuplicateObj(objv[i]);
309        ret = Tcl_ListObjAppendElement(interp, svObj->tclObj, dup);
310        if (ret != TCL_OK) {
311            Tcl_DecrRefCount(dup);
312            goto cmd_err;
313        }
314    }
315
316    Tcl_SetObjResult(interp, Sv_DuplicateObj(svObj->tclObj));
317
318    return Sv_PutContainer(interp, svObj, SV_CHANGED);
319
320 cmd_err:
321    return Sv_PutContainer(interp, svObj, SV_ERROR);
322}
323
324/*
325 *-----------------------------------------------------------------------------
326 *
327 * SvLreplaceObjCmd --
328 *
329 *      This procedure is invoked to process the "tsv::lreplace" command.
330 *      See the user documentation for details on what it does.
331 *
332 * Results:
333 *      A standard Tcl result.
334 *
335 * Side effects:
336 *      See the user documentation.
337 *
338 *-----------------------------------------------------------------------------
339 */
340
341static int
342SvLreplaceObjCmd (arg, interp, objc, objv)
343    ClientData arg;
344    Tcl_Interp *interp;
345    int objc;
346    Tcl_Obj *const objv[];
347{
348    const char *firstArg;
349    int argLen, ret, off, llen, first, last, ndel, nargs, i, j;
350    Tcl_Obj **args = NULL;
351    Container *svObj = (Container*)arg;
352
353    /*
354     * Syntax:
355     *          tsv::lreplace array key first last ?element ...?
356     *          $list lreplace first last ?element ...?
357     */
358
359    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
360    if (ret != TCL_OK) {
361        return TCL_ERROR;
362    }
363    if ((objc - off) < 2) {
364        Tcl_WrongNumArgs(interp, off, objv, "first last ?element ...?");
365        goto cmd_err;
366    }
367    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
368    if (ret != TCL_OK) {
369        goto cmd_err;
370    }
371    ret = SvGetIntForIndex(interp, objv[off], llen-1, &first);
372    if (ret != TCL_OK) {
373        goto cmd_err;
374    }
375    ret = SvGetIntForIndex(interp, objv[off+1], llen-1, &last);
376    if (ret != TCL_OK) {
377        goto cmd_err;
378    }
379
380    firstArg = Tcl_GetStringFromObj(objv[off], &argLen);
381    if (first < 0)  {
382        first = 0;
383    }
384    if (llen && first >= llen && strncmp(firstArg, "end", argLen)) {
385        Tcl_AppendResult(interp, "list doesn't have element ", firstArg, NULL);
386        goto cmd_err;
387    }
388    if (last >= llen) {
389        last = llen - 1;
390    }
391    if (first <= last) {
392        ndel = last - first + 1;
393    } else {
394        ndel = 0;
395    }
396
397    nargs = objc - (off + 2);
398    if (nargs) {
399        args = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
400        for(i = off + 2, j = 0; i < objc; i++, j++) {
401            args[j] = Sv_DuplicateObj(objv[i]);
402        }
403    }
404
405    ret = Tcl_ListObjReplace(interp, svObj->tclObj, first, ndel, nargs, args);
406    if (args) {
407        if (ret != TCL_OK) {
408            for(i = off + 2, j = 0; i < objc; i++, j++) {
409                Tcl_DecrRefCount(args[j]);
410            }
411        }
412        Tcl_Free((char*)args);
413    }
414
415    return Sv_PutContainer(interp, svObj, SV_CHANGED);
416
417 cmd_err:
418    return Sv_PutContainer(interp, svObj, SV_ERROR);
419}
420
421/*
422 *-----------------------------------------------------------------------------
423 *
424 * SvLrangeObjCmd --
425 *
426 *      This procedure is invoked to process the "tsv::lrange" command.
427 *      See the user documentation for details on what it does.
428 *
429 * Results:
430 *      A standard Tcl result.
431 *
432 * Side effects:
433 *      See the user documentation.
434 *
435 *-----------------------------------------------------------------------------
436 */
437
438static int
439SvLrangeObjCmd (arg, interp, objc, objv)
440    ClientData arg;
441    Tcl_Interp *interp;
442    int objc;
443    Tcl_Obj *const objv[];
444{
445    int ret, off, llen, first, last, nargs, i, j;
446    Tcl_Obj **elPtrs, **args;
447    Container *svObj = (Container*)arg;
448
449    /*
450     * Syntax:
451     *          tsv::lrange array key first last
452     *          $list lrange first last
453     */
454
455    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
456    if (ret != TCL_OK) {
457        return TCL_ERROR;
458    }
459    if ((objc - off) != 2) {
460        Tcl_WrongNumArgs(interp, off, objv, "first last");
461        goto cmd_err;
462    }
463    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs);
464    if (ret != TCL_OK) {
465        goto cmd_err;
466    }
467    ret = SvGetIntForIndex(interp, objv[off], llen-1, &first);
468    if (ret != TCL_OK) {
469        goto cmd_err;
470    }
471    ret = SvGetIntForIndex(interp, objv[off+1], llen-1, &last);
472    if (ret != TCL_OK) {
473        goto cmd_err;
474    }
475    if (first < 0)  {
476        first = 0;
477    }
478    if (last >= llen) {
479        last = llen - 1;
480    }
481    if (first > last) {
482        goto cmd_ok;
483    }
484
485    nargs = last - first + 1;
486    args  = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
487    for (i = first, j = 0; i <= last; i++, j++) {
488        args[j] = Sv_DuplicateObj(elPtrs[i]);
489    }
490
491    Tcl_ResetResult(interp);
492    Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args);
493    Tcl_Free((char*)args);
494
495 cmd_ok:
496    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
497
498 cmd_err:
499    return Sv_PutContainer(interp, svObj, SV_ERROR);
500}
501
502/*
503 *-----------------------------------------------------------------------------
504 *
505 * SvLinsertObjCmd --
506 *
507 *      This procedure is invoked to process the "tsv::linsert" command.
508 *      See the user documentation for details on what it does.
509 *
510 * Results:
511 *      A standard Tcl result.
512 *
513 * Side effects:
514 *      See the user documentation.
515 *
516 *-----------------------------------------------------------------------------
517 */
518
519static int
520SvLinsertObjCmd (arg, interp, objc, objv)
521    ClientData arg;
522    Tcl_Interp *interp;
523    int objc;
524    Tcl_Obj *const objv[];
525{
526    int off, ret, flg, llen, nargs, index = 0, i, j;
527    Tcl_Obj **args;
528    Container *svObj = (Container*)arg;
529
530    /*
531     * Syntax:
532     *          tsv::linsert array key index element ?element ...?
533     *          $list linsert element ?element ...?
534     */
535
536    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
537    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
538    if (ret != TCL_OK) {
539        return TCL_ERROR;
540    }
541    if ((objc - off) < 2) {
542        Tcl_WrongNumArgs(interp, off, objv, "index element ?element ...?");
543        goto cmd_err;
544    }
545    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
546    if (ret != TCL_OK) {
547        goto cmd_err;
548    }
549    ret = SvGetIntForIndex(interp, objv[off], llen, &index);
550    if (ret != TCL_OK) {
551        goto cmd_err;
552    }
553    if (index < 0) {
554        index = 0;
555    } else if (index > llen) {
556        index = llen;
557    }
558
559    nargs = objc - (off + 1);
560    args  = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
561    for (i = off + 1, j = 0; i < objc; i++, j++) {
562         args[j] = Sv_DuplicateObj(objv[i]);
563    }
564    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, nargs, args);
565    if (ret != TCL_OK) {
566        for (i = off + 1, j = 0; i < objc; i++, j++) {
567            Tcl_DecrRefCount(args[j]);
568        }
569        Tcl_Free((char*)args);
570        goto cmd_err;
571    }
572
573    Tcl_Free((char*)args);
574
575    return Sv_PutContainer(interp, svObj, SV_CHANGED);
576
577 cmd_err:
578    return Sv_PutContainer(interp, svObj, SV_ERROR);
579}
580
581/*
582 *-----------------------------------------------------------------------------
583 *
584 * SvLlengthObjCmd --
585 *
586 *      This procedure is invoked to process the "tsv::llength" command.
587 *      See the user documentation for details on what it does.
588 *
589 * Results:
590 *      A standard Tcl result.
591 *
592 * Side effects:
593 *      See the user documentation.
594 *
595 *-----------------------------------------------------------------------------
596 */
597
598static int
599SvLlengthObjCmd (arg, interp, objc, objv)
600    ClientData arg;
601    Tcl_Interp *interp;
602    int objc;
603    Tcl_Obj *const objv[];
604{
605    int llen, off, ret;
606    Container *svObj = (Container*)arg;
607
608    /*
609     * Syntax:
610     *          tsv::llength array key
611     *          $list llength
612     */
613
614    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
615    if (ret != TCL_OK) {
616        return TCL_ERROR;
617    }
618
619    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
620    if (ret == TCL_OK) {
621        Tcl_ResetResult(interp);
622        Tcl_SetIntObj(Tcl_GetObjResult(interp), llen);
623    }
624    if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) {
625        return TCL_ERROR;
626    }
627
628    return ret;
629}
630
631/*
632 *-----------------------------------------------------------------------------
633 *
634 * SvLsearchObjCmd --
635 *
636 *      This procedure is invoked to process the "tsv::lsearch" command.
637 *      See the user documentation for details on what it does.
638 *
639 * Results:
640 *      A standard Tcl result.
641 *
642 * Side effects:
643 *      See the user documentation.
644 *
645 *-----------------------------------------------------------------------------
646 */
647
648static int
649SvLsearchObjCmd (arg, interp, objc, objv)
650    ClientData arg;
651    Tcl_Interp *interp;
652    int objc;
653    Tcl_Obj *const objv[];
654{
655    int ret, off, listc, mode, imode, ipatt, length, index, match, i;
656    const char *patBytes;
657    Tcl_Obj **listv;
658    Container *svObj = (Container*)arg;
659
660    static const char *modes[] = {"-exact", "-glob", "-regexp", NULL};
661    enum {LS_EXACT, LS_GLOB, LS_REGEXP};
662
663    mode = LS_GLOB;
664
665    /*
666     * Syntax:
667     *          tsv::lsearch array key ?mode? pattern
668     *          $list lsearch ?mode? pattern
669     */
670
671    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
672    if (ret != TCL_OK) {
673        return TCL_ERROR;
674    }
675    if ((objc - off) == 2) {
676        imode = off;
677        ipatt = off + 1;
678    } else if ((objc - off) == 1) {
679        imode = 0;
680        ipatt = off;
681    } else {
682        Tcl_WrongNumArgs(interp, off, objv, "?mode? pattern");
683        goto cmd_err;
684    }
685    if (imode) {
686        ret = Tcl_GetIndexFromObj(interp, objv[imode], modes, "search mode",
687                0, &mode);
688        if (ret != TCL_OK) {
689            goto cmd_err;
690        }
691    }
692    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &listc, &listv);
693    if (ret != TCL_OK) {
694        goto cmd_err;
695    }
696
697    index = -1;
698    patBytes = Tcl_GetStringFromObj(objv[ipatt], &length);
699
700    for (i = 0; i < listc; i++) {
701        match = 0;
702        switch (mode) {
703        case LS_GLOB:
704            match = Tcl_StringMatch(Tcl_GetString(listv[i]), patBytes);
705            break;
706
707        case LS_EXACT: {
708            int elemLen;
709            const char *bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
710            if (length == elemLen) {
711                match = (memcmp(bytes, patBytes, (size_t)length) == 0);
712            }
713            break;
714        }
715        case LS_REGEXP:
716            match = Tcl_RegExpMatchObj(interp, listv[i], objv[ipatt]);
717            if (match < 0) {
718                goto cmd_err;
719            }
720            break;
721        }
722        if (match) {
723            index = i;
724            break;
725        }
726    }
727
728    Tcl_ResetResult(interp);
729    Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
730
731    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
732
733 cmd_err:
734    return Sv_PutContainer(interp, svObj, SV_ERROR);
735}
736
737/*
738 *-----------------------------------------------------------------------------
739 *
740 * SvLindexObjCmd --
741 *
742 *      This procedure is invoked to process the "tsv::lindex" command.
743 *      See the user documentation for details on what it does.
744 *
745 * Results:
746 *      A standard Tcl result.
747 *
748 * Side effects:
749 *      See the user documentation.
750 *
751 *-----------------------------------------------------------------------------
752 */
753
754static int
755SvLindexObjCmd (arg, interp, objc, objv)
756    ClientData arg;
757    Tcl_Interp *interp;
758    int objc;
759    Tcl_Obj *const objv[];
760{
761    Tcl_Obj **elPtrs;
762    int ret, off, llen, index;
763    Container *svObj = (Container*)arg;
764
765    /*
766     * Syntax:
767     *          tsv::lindex array key index
768     *          $list lindex index
769     */
770
771    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
772    if (ret != TCL_OK) {
773        return TCL_ERROR;
774    }
775    if ((objc - off) != 1) {
776        Tcl_WrongNumArgs(interp, off, objv, "index");
777        goto cmd_err;
778    }
779    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs);
780    if (ret != TCL_OK) {
781        goto cmd_err;
782    }
783    ret = SvGetIntForIndex(interp, objv[off], llen-1, &index);
784    if (ret != TCL_OK) {
785        goto cmd_err;
786    }
787    if (index >= 0 && index < llen) {
788        Tcl_SetObjResult(interp, Sv_DuplicateObj(elPtrs[index]));
789    }
790
791    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
792
793 cmd_err:
794    return Sv_PutContainer(interp, svObj, SV_ERROR);
795}
796
797/*
798 *-----------------------------------------------------------------------------
799 *
800 * SvLsetObjCmd --
801 *
802 *      This procedure is invoked to process the "tsv::lset" command.
803 *      See the user documentation for details on what it does.
804 *
805 * Results:
806 *      A standard Tcl result.
807 *
808 * Side effects:
809 *      See the user documentation.
810 *
811 *-----------------------------------------------------------------------------
812 */
813
814static int
815SvLsetObjCmd (arg, interp, objc, objv)
816    ClientData arg;
817    Tcl_Interp *interp;
818    int objc;
819    Tcl_Obj *const objv[];
820{
821    Tcl_Obj *lPtr;
822    int ret, argc, off;
823    Container *svObj = (Container*)arg;
824
825    /*
826     * Syntax:
827     *          tsv::lset array key index ?index ...? value
828     *          $list lset index ?index ...? value
829     */
830
831    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
832    if (ret != TCL_OK) {
833        return TCL_ERROR;
834    }
835    if ((objc - off) < 2) {
836        Tcl_WrongNumArgs(interp, off, objv, "index ?index...? value");
837        goto cmd_err;
838    }
839
840    lPtr = svObj->tclObj;
841    argc = objc - off - 1;
842
843    if (!SvLsetFlat(interp, lPtr, argc, (Tcl_Obj**)(objv+off),objv[objc-1])) {
844        return TCL_ERROR;
845    }
846
847    Tcl_SetObjResult(interp, Sv_DuplicateObj(lPtr));
848
849    return Sv_PutContainer(interp, svObj, SV_CHANGED);
850
851 cmd_err:
852    return Sv_PutContainer(interp, svObj, SV_ERROR);
853}
854
855/*
856 *-----------------------------------------------------------------------------
857 *
858 * DupListObjShared --
859 *
860 *      Help function to make a proper deep copy of the list object.
861 *      This is used as the replacement-hook for list object native
862 *      DupInternalRep function. We need it since the native function
863 *      does a shallow list copy, i.e. retains references to list
864 *      element objects from the original list. This gives us trouble
865 *      when making the list object shared between threads.
866 *
867 * Results:
868 *      None.
869 *
870 * Side effects;
871 *      This is not a very efficient implementation, but that's all what's
872 *      available to Tcl API programmer. We could include the tclInt.h and
873 *      get the copy more efficient using list internals, but ...
874 *
875 *-----------------------------------------------------------------------------
876 */
877
878static void
879DupListObjShared(srcPtr, copyPtr)
880    Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */
881    Tcl_Obj *copyPtr;           /* Object with internal rep to set. */
882{
883    int i, llen;
884    Tcl_Obj *elObj, **newObjList;
885
886    Tcl_ListObjLength(NULL, srcPtr, &llen);
887    if (llen == 0) {
888        (*srcPtr->typePtr->dupIntRepProc)(srcPtr, copyPtr);
889        copyPtr->refCount = 0;
890        return;
891    }
892
893    newObjList = (Tcl_Obj**)Tcl_Alloc(llen*sizeof(Tcl_Obj*));
894
895    for (i = 0; i < llen; i++) {
896        Tcl_ListObjIndex(NULL, srcPtr, i, &elObj);
897        newObjList[i] = Sv_DuplicateObj(elObj);
898    }
899
900    Tcl_SetListObj(copyPtr, llen, newObjList);
901
902    Tcl_Free((char*)newObjList);
903}
904
905/*
906 *-----------------------------------------------------------------------------
907 *
908 * SvCheckBadOctal --
909 *
910 *  Exact copy from the TclCheckBadOctal found in tclUtil.c
911 *  since this is not in the stubs table.
912 *
913 *-----------------------------------------------------------------------------
914 */
915
916static int
917SvCheckBadOctal(interp, value)
918    Tcl_Interp *interp;     /* Interpreter to use for error reporting.
919                             * If NULL, then no error message is left
920                             * after errors. */
921    const char *value;      /* String to check. */
922{
923    register const char *p = value;
924
925    /*
926     * A frequent mistake is invalid octal values due to an unwanted
927     * leading zero. Try to generate a meaningful error message.
928     */
929
930    while (isspace((unsigned char)(*p))) { /* INTL: ISO space. */
931        p++;
932    }
933    if (*p == '+' || *p == '-') {
934        p++;
935    }
936    if (*p == '0') {
937        while (isdigit((unsigned char)(*p))) { /* INTL: digit. */
938            p++;
939        }
940        while (isspace((unsigned char)(*p))) { /* INTL: ISO space. */
941            p++;
942        }
943        if (*p == '\0') {
944            /* Reached end of string */
945            if (interp != NULL) {
946                Tcl_AppendResult(interp, " (looks like invalid octal number)",
947                        (char *) NULL);
948            }
949            return 1;
950        }
951    }
952    return 0;
953}
954
955/*
956 *-----------------------------------------------------------------------------
957 *
958 * SvGetIntForIndex --
959 *
960 *  Exact copy from the TclGetIntForIndex found in tclUtil.c
961 *  since this is not in the stubs table.
962 *
963 *-----------------------------------------------------------------------------
964 */
965
966static int
967SvGetIntForIndex(interp, objPtr, endValue, indexPtr)
968    Tcl_Interp *interp;     /* Interpreter to use for error reporting.
969                             * If NULL, then no error message is left
970                             * after errors. */
971    Tcl_Obj *objPtr;        /* Points to an object containing either
972                             * "end" or an integer. */
973    int endValue;           /* The value to be stored at "indexPtr" if
974                             * "objPtr" holds "end". */
975    int *indexPtr;          /* Location filled in with an integer
976                             * representing an index. */
977{
978    const char *bytes;
979    int length, offset;
980
981    bytes = Tcl_GetStringFromObj(objPtr, &length);
982
983    if ((*bytes != 'e')
984        || (strncmp(bytes, "end",(size_t)((length > 3) ? 3 : length)) != 0)) {
985        if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) {
986            goto intforindex_error;
987        }
988        *indexPtr = offset;
989        return TCL_OK;
990    }
991    if (length <= 3) {
992        *indexPtr = endValue;
993    } else if (bytes[3] == '-') {
994        /*
995         * This is our limited string expression evaluator
996         */
997        if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) {
998            return TCL_ERROR;
999        }
1000        *indexPtr = endValue + offset;
1001    } else {
1002  intforindex_error:
1003        if (interp != NULL) {
1004            Tcl_ResetResult(interp);
1005            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad index \"",
1006                    bytes, "\": must be integer or end?-integer?",(char*)NULL);
1007            SvCheckBadOctal(interp, bytes);
1008        }
1009        return TCL_ERROR;
1010    }
1011    return TCL_OK;
1012}
1013
1014/*
1015 *----------------------------------------------------------------------
1016 *
1017 * SvLsetFlat --
1018 *
1019 *  Almost exact copy from the TclLsetFlat found in tclListObj.c.
1020 *  Simplified in a sense that thread shared objects are guaranteed
1021 *  to be non-shared.
1022 *
1023 *  Actual return value of this procedure is irrelevant to the caller,
1024 *  and it should be either NULL or non-NULL.
1025 *
1026 *----------------------------------------------------------------------
1027 */
1028
1029static Tcl_Obj*
1030SvLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
1031     Tcl_Interp *interp;     /* Tcl interpreter */
1032     Tcl_Obj *listPtr;       /* Pointer to the list being modified */
1033     int indexCount;         /* Number of index args */
1034     Tcl_Obj **indexArray;
1035     Tcl_Obj *valuePtr;      /* Value arg to 'lset' */
1036{
1037    int elemCount, index, result, i;
1038    Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;
1039
1040    /*
1041     * Determine whether the index arg designates a list
1042     * or a single index.
1043     */
1044
1045    if (indexCount == 1 &&
1046        Tcl_ListObjGetElements(interp, indexArray[0], &indexCount,
1047                               &indexArray) != TCL_OK) {
1048        /*
1049         * Index arg designates something that is neither an index
1050         * nor a well formed list.
1051         */
1052
1053        return NULL;
1054    }
1055
1056    /*
1057     * If there are no indices, then simply return the new value,
1058     * counting the returned pointer as a reference
1059     */
1060
1061    if (indexCount == 0) {
1062        return valuePtr;
1063    }
1064
1065    /*
1066     * Anchor the linked list of Tcl_Obj's whose string reps must be
1067     * invalidated if the operation succeeds.
1068     */
1069
1070    chainPtr = NULL;
1071
1072    /*
1073     * Handle each index arg by diving into the appropriate sublist
1074     */
1075
1076    for (i = 0; ; ++i) {
1077
1078        /*
1079         * Take the sublist apart.
1080         */
1081
1082        result = Tcl_ListObjGetElements(interp,listPtr,&elemCount,&elemPtrs);
1083        if (result != TCL_OK) {
1084            break;
1085        }
1086
1087        listPtr->internalRep.twoPtrValue.ptr2 = (VOID*)chainPtr;
1088
1089        /*
1090         * Determine the index of the requested element.
1091         */
1092
1093        result = SvGetIntForIndex(interp, indexArray[i], elemCount-1, &index);
1094        if (result != TCL_OK) {
1095            break;
1096        }
1097
1098        /*
1099         * Check that the index is in range.
1100         */
1101
1102        if (index < 0 || index >= elemCount) {
1103            Tcl_SetObjResult(interp,
1104                             Tcl_NewStringObj("list index out of range", -1));
1105            result = TCL_ERROR;
1106            break;
1107        }
1108
1109        /*
1110         * Break the loop after extracting the innermost sublist
1111         */
1112
1113        if (i >= (indexCount - 1)) {
1114            result = TCL_OK;
1115            break;
1116        }
1117
1118        /*
1119         * Extract the appropriate sublist and chain it onto the linked
1120         * list of Tcl_Obj's whose string reps must be spoilt.
1121         */
1122
1123        subListPtr = elemPtrs[index];
1124        chainPtr = listPtr;
1125        listPtr = subListPtr;
1126    }
1127
1128    /* Store the result in the list element */
1129
1130    if (result == TCL_OK) {
1131        result = Tcl_ListObjGetElements(interp,listPtr,&elemCount,&elemPtrs);
1132        if (result == TCL_OK) {
1133            Tcl_DecrRefCount(elemPtrs[index]);
1134            elemPtrs[index] = Sv_DuplicateObj(valuePtr);
1135            Tcl_IncrRefCount(elemPtrs[index]);
1136        }
1137    }
1138
1139    if (result == TCL_OK) {
1140        listPtr->internalRep.twoPtrValue.ptr2 = (VOID*)chainPtr;
1141        /* Spoil all the string reps */
1142        while (listPtr != NULL) {
1143            subListPtr = (Tcl_Obj*)listPtr->internalRep.twoPtrValue.ptr2;
1144            Tcl_InvalidateStringRep(listPtr);
1145            listPtr->internalRep.twoPtrValue.ptr2 = NULL;
1146            listPtr = subListPtr;
1147        }
1148
1149        return valuePtr;
1150    }
1151
1152    return NULL;
1153}
1154
1155/* EOF $RCSfile: threadSvListCmd.c,v $ */
1156
1157/* Emacs Setup Variables */
1158/* Local Variables:      */
1159/* mode: C               */
1160/* indent-tabs-mode: nil */
1161/* c-basic-offset: 4     */
1162/* End:                  */
1163
1164