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