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