1/* 2 * tclTestObj.c -- 3 * 4 * This file contains C command functions for the additional Tcl commands 5 * that are used for testing implementations of the Tcl object types. 6 * These commands are not normally included in Tcl applications; they're 7 * only used for testing. 8 * 9 * Copyright (c) 1995-1998 Sun Microsystems, Inc. 10 * Copyright (c) 1999 by Scriptics Corporation. 11 * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. 12 * 13 * See the file "license.terms" for information on usage and redistribution of 14 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 * 16 * RCS: @(#) $Id: tclTestObj.c,v 1.21.2.3 2010/03/19 15:29:28 dgp Exp $ 17 */ 18 19#include "tclInt.h" 20#include "tommath.h" 21 22/* 23 * An array of Tcl_Obj pointers used in the commands that operate on or get 24 * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's 25 * Tcl_Obj *. 26 */ 27 28#define NUMBER_OF_OBJECT_VARS 20 29static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS]; 30 31/* 32 * Forward declarations for functions defined later in this file: 33 */ 34 35static int CheckIfVarUnset(Tcl_Interp *interp, int varIndex); 36static int GetVariableIndex(Tcl_Interp *interp, 37 const char *string, int *indexPtr); 38static void SetVarToObj(int varIndex, Tcl_Obj *objPtr); 39int TclObjTest_Init(Tcl_Interp *interp); 40static int TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp, 41 int objc, Tcl_Obj *const objv[]); 42static int TestbooleanobjCmd(ClientData dummy, 43 Tcl_Interp *interp, int objc, 44 Tcl_Obj *const objv[]); 45static int TestdoubleobjCmd(ClientData dummy, Tcl_Interp *interp, 46 int objc, Tcl_Obj *const objv[]); 47static int TestindexobjCmd(ClientData dummy, Tcl_Interp *interp, 48 int objc, Tcl_Obj *const objv[]); 49static int TestintobjCmd(ClientData dummy, Tcl_Interp *interp, 50 int objc, Tcl_Obj *const objv[]); 51static int TestlistobjCmd(ClientData dummy, Tcl_Interp *interp, 52 int objc, Tcl_Obj *const objv[]); 53static int TestobjCmd(ClientData dummy, Tcl_Interp *interp, 54 int objc, Tcl_Obj *const objv[]); 55static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, 56 int objc, Tcl_Obj *const objv[]); 57 58typedef struct TestString { 59 int numChars; 60 size_t allocated; 61 size_t uallocated; 62 Tcl_UniChar unicode[2]; 63} TestString; 64 65/* 66 *---------------------------------------------------------------------- 67 * 68 * TclObjTest_Init -- 69 * 70 * This function creates additional commands that are used to test the 71 * Tcl object support. 72 * 73 * Results: 74 * Returns a standard Tcl completion code, and leaves an error 75 * message in the interp's result if an error occurs. 76 * 77 * Side effects: 78 * Creates and registers several new testing commands. 79 * 80 *---------------------------------------------------------------------- 81 */ 82 83int 84TclObjTest_Init( 85 Tcl_Interp *interp) 86{ 87 register int i; 88 89 for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { 90 varPtr[i] = NULL; 91 } 92 93 Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd, 94 (ClientData) 0, NULL); 95 Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd, 96 (ClientData) 0, NULL); 97 Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd, 98 (ClientData) 0, NULL); 99 Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd, 100 (ClientData) 0, NULL); 101 Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd, 102 (ClientData) 0, NULL); 103 Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd, 104 (ClientData) 0, NULL); 105 Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, (ClientData) 0, NULL); 106 Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, 107 (ClientData) 0, NULL); 108 return TCL_OK; 109} 110 111/* 112 *---------------------------------------------------------------------- 113 * 114 * TestbignumobjCmd -- 115 * 116 * This function implmenets the "testbignumobj" command. It is used 117 * to exercise the bignum Tcl object type implementation. 118 * 119 * Results: 120 * Returns a standard Tcl object result. 121 * 122 * Side effects: 123 * Creates and frees bignum objects; converts objects to have bignum 124 * type. 125 * 126 *---------------------------------------------------------------------- 127 */ 128 129static int 130TestbignumobjCmd( 131 ClientData clientData, /* unused */ 132 Tcl_Interp *interp, /* Tcl interpreter */ 133 int objc, /* Argument count */ 134 Tcl_Obj *const objv[]) /* Argument vector */ 135{ 136 const char * subcmds[] = { 137 "set", "get", "mult10", "div10", NULL 138 }; 139 enum options { 140 BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10 141 }; 142 143 int index, varIndex; 144 char* string; 145 mp_int bignumValue, newValue; 146 147 if (objc < 3) { 148 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?..."); 149 return TCL_ERROR; 150 } 151 if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, 152 &index) != TCL_OK) { 153 return TCL_ERROR; 154 } 155 string = Tcl_GetString(objv[2]); 156 if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) { 157 return TCL_ERROR; 158 } 159 160 switch (index) { 161 case BIGNUM_SET: 162 if (objc != 4) { 163 Tcl_WrongNumArgs(interp, 2, objv, "var value"); 164 return TCL_ERROR; 165 } 166 string = Tcl_GetString(objv[3]); 167 if (mp_init(&bignumValue) != MP_OKAY) { 168 Tcl_SetObjResult(interp, 169 Tcl_NewStringObj("error in mp_init", -1)); 170 return TCL_ERROR; 171 } 172 if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) { 173 mp_clear(&bignumValue); 174 Tcl_SetObjResult(interp, 175 Tcl_NewStringObj("error in mp_read_radix", -1)); 176 return TCL_ERROR; 177 } 178 179 /* 180 * If the object currently bound to the variable with index varIndex 181 * has ref count 1 (i.e. the object is unshared) we can modify that 182 * object directly. Otherwise, if RC>1 (i.e. the object is shared), 183 * we must create a new object to modify/set and decrement the old 184 * formerly-shared object's ref count. This is "copy on write". 185 */ 186 187 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 188 Tcl_SetBignumObj(varPtr[varIndex], &bignumValue); 189 } else { 190 SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue)); 191 } 192 break; 193 194 case BIGNUM_GET: 195 if (objc != 3) { 196 Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); 197 return TCL_ERROR; 198 } 199 if (CheckIfVarUnset(interp, varIndex)) { 200 return TCL_ERROR; 201 } 202 break; 203 204 case BIGNUM_MULT10: 205 if (objc != 3) { 206 Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); 207 return TCL_ERROR; 208 } 209 if (CheckIfVarUnset(interp, varIndex)) { 210 return TCL_ERROR; 211 } 212 if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], 213 &bignumValue) != TCL_OK) { 214 return TCL_ERROR; 215 } 216 if (mp_init(&newValue) != MP_OKAY 217 || (mp_mul_d(&bignumValue, 10, &newValue) != MP_OKAY)) { 218 mp_clear(&bignumValue); 219 mp_clear(&newValue); 220 Tcl_SetObjResult(interp, 221 Tcl_NewStringObj("error in mp_mul_d", -1)); 222 return TCL_ERROR; 223 } 224 mp_clear(&bignumValue); 225 if (!Tcl_IsShared(varPtr[varIndex])) { 226 Tcl_SetBignumObj(varPtr[varIndex], &newValue); 227 } else { 228 SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); 229 } 230 break; 231 232 case BIGNUM_DIV10: 233 if (objc != 3) { 234 Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); 235 return TCL_ERROR; 236 } 237 if (CheckIfVarUnset(interp, varIndex)) { 238 return TCL_ERROR; 239 } 240 if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], 241 &bignumValue) != TCL_OK) { 242 return TCL_ERROR; 243 } 244 if (mp_init(&newValue) != MP_OKAY 245 || (mp_div_d(&bignumValue, 10, &newValue, NULL) != MP_OKAY)) { 246 mp_clear(&bignumValue); 247 mp_clear(&newValue); 248 Tcl_SetObjResult(interp, 249 Tcl_NewStringObj("error in mp_div_d", -1)); 250 return TCL_ERROR; 251 } 252 mp_clear(&bignumValue); 253 if (!Tcl_IsShared(varPtr[varIndex])) { 254 Tcl_SetBignumObj(varPtr[varIndex], &newValue); 255 } else { 256 SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue)); 257 } 258 } 259 260 Tcl_SetObjResult(interp, varPtr[varIndex]); 261 return TCL_OK; 262} 263 264/* 265 *---------------------------------------------------------------------- 266 * 267 * TestbooleanobjCmd -- 268 * 269 * This function implements the "testbooleanobj" command. It is used to 270 * test the boolean Tcl object type implementation. 271 * 272 * Results: 273 * A standard Tcl object result. 274 * 275 * Side effects: 276 * Creates and frees boolean objects, and also converts objects to 277 * have boolean type. 278 * 279 *---------------------------------------------------------------------- 280 */ 281 282static int 283TestbooleanobjCmd( 284 ClientData clientData, /* Not used. */ 285 Tcl_Interp *interp, /* Current interpreter. */ 286 int objc, /* Number of arguments. */ 287 Tcl_Obj *const objv[]) /* Argument objects. */ 288{ 289 int varIndex, boolValue; 290 char *index, *subCmd; 291 292 if (objc < 3) { 293 wrongNumArgs: 294 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); 295 return TCL_ERROR; 296 } 297 298 index = Tcl_GetString(objv[2]); 299 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 300 return TCL_ERROR; 301 } 302 303 subCmd = Tcl_GetString(objv[1]); 304 if (strcmp(subCmd, "set") == 0) { 305 if (objc != 4) { 306 goto wrongNumArgs; 307 } 308 if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) { 309 return TCL_ERROR; 310 } 311 312 /* 313 * If the object currently bound to the variable with index varIndex 314 * has ref count 1 (i.e. the object is unshared) we can modify that 315 * object directly. Otherwise, if RC>1 (i.e. the object is shared), 316 * we must create a new object to modify/set and decrement the old 317 * formerly-shared object's ref count. This is "copy on write". 318 */ 319 320 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 321 Tcl_SetBooleanObj(varPtr[varIndex], boolValue); 322 } else { 323 SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue)); 324 } 325 Tcl_SetObjResult(interp, varPtr[varIndex]); 326 } else if (strcmp(subCmd, "get") == 0) { 327 if (objc != 3) { 328 goto wrongNumArgs; 329 } 330 if (CheckIfVarUnset(interp, varIndex)) { 331 return TCL_ERROR; 332 } 333 Tcl_SetObjResult(interp, varPtr[varIndex]); 334 } else if (strcmp(subCmd, "not") == 0) { 335 if (objc != 3) { 336 goto wrongNumArgs; 337 } 338 if (CheckIfVarUnset(interp, varIndex)) { 339 return TCL_ERROR; 340 } 341 if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex], 342 &boolValue) != TCL_OK) { 343 return TCL_ERROR; 344 } 345 if (!Tcl_IsShared(varPtr[varIndex])) { 346 Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); 347 } else { 348 SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue)); 349 } 350 Tcl_SetObjResult(interp, varPtr[varIndex]); 351 } else { 352 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 353 "bad option \"", Tcl_GetString(objv[1]), 354 "\": must be set, get, or not", NULL); 355 return TCL_ERROR; 356 } 357 return TCL_OK; 358} 359 360/* 361 *---------------------------------------------------------------------- 362 * 363 * TestdoubleobjCmd -- 364 * 365 * This function implements the "testdoubleobj" command. It is used to 366 * test the double-precision floating point Tcl object type 367 * implementation. 368 * 369 * Results: 370 * A standard Tcl object result. 371 * 372 * Side effects: 373 * Creates and frees double objects, and also converts objects to 374 * have double type. 375 * 376 *---------------------------------------------------------------------- 377 */ 378 379static int 380TestdoubleobjCmd( 381 ClientData clientData, /* Not used. */ 382 Tcl_Interp *interp, /* Current interpreter. */ 383 int objc, /* Number of arguments. */ 384 Tcl_Obj *const objv[]) /* Argument objects. */ 385{ 386 int varIndex; 387 double doubleValue; 388 char *index, *subCmd, *string; 389 390 if (objc < 3) { 391 wrongNumArgs: 392 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); 393 return TCL_ERROR; 394 } 395 396 index = Tcl_GetString(objv[2]); 397 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 398 return TCL_ERROR; 399 } 400 401 subCmd = Tcl_GetString(objv[1]); 402 if (strcmp(subCmd, "set") == 0) { 403 if (objc != 4) { 404 goto wrongNumArgs; 405 } 406 string = Tcl_GetString(objv[3]); 407 if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) { 408 return TCL_ERROR; 409 } 410 411 /* 412 * If the object currently bound to the variable with index varIndex 413 * has ref count 1 (i.e. the object is unshared) we can modify that 414 * object directly. Otherwise, if RC>1 (i.e. the object is shared), we 415 * must create a new object to modify/set and decrement the old 416 * formerly-shared object's ref count. This is "copy on write". 417 */ 418 419 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 420 Tcl_SetDoubleObj(varPtr[varIndex], doubleValue); 421 } else { 422 SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue)); 423 } 424 Tcl_SetObjResult(interp, varPtr[varIndex]); 425 } else if (strcmp(subCmd, "get") == 0) { 426 if (objc != 3) { 427 goto wrongNumArgs; 428 } 429 if (CheckIfVarUnset(interp, varIndex)) { 430 return TCL_ERROR; 431 } 432 Tcl_SetObjResult(interp, varPtr[varIndex]); 433 } else if (strcmp(subCmd, "mult10") == 0) { 434 if (objc != 3) { 435 goto wrongNumArgs; 436 } 437 if (CheckIfVarUnset(interp, varIndex)) { 438 return TCL_ERROR; 439 } 440 if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], 441 &doubleValue) != TCL_OK) { 442 return TCL_ERROR; 443 } 444 if (!Tcl_IsShared(varPtr[varIndex])) { 445 Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0)); 446 } else { 447 SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) )); 448 } 449 Tcl_SetObjResult(interp, varPtr[varIndex]); 450 } else if (strcmp(subCmd, "div10") == 0) { 451 if (objc != 3) { 452 goto wrongNumArgs; 453 } 454 if (CheckIfVarUnset(interp, varIndex)) { 455 return TCL_ERROR; 456 } 457 if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex], 458 &doubleValue) != TCL_OK) { 459 return TCL_ERROR; 460 } 461 if (!Tcl_IsShared(varPtr[varIndex])) { 462 Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0)); 463 } else { 464 SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) )); 465 } 466 Tcl_SetObjResult(interp, varPtr[varIndex]); 467 } else { 468 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 469 "bad option \"", Tcl_GetString(objv[1]), 470 "\": must be set, get, mult10, or div10", NULL); 471 return TCL_ERROR; 472 } 473 return TCL_OK; 474} 475 476/* 477 *---------------------------------------------------------------------- 478 * 479 * TestindexobjCmd -- 480 * 481 * This function implements the "testindexobj" command. It is used to 482 * test the index Tcl object type implementation. 483 * 484 * Results: 485 * A standard Tcl object result. 486 * 487 * Side effects: 488 * Creates and frees int objects, and also converts objects to 489 * have int type. 490 * 491 *---------------------------------------------------------------------- 492 */ 493 494static int 495TestindexobjCmd( 496 ClientData clientData, /* Not used. */ 497 Tcl_Interp *interp, /* Current interpreter. */ 498 int objc, /* Number of arguments. */ 499 Tcl_Obj *const objv[]) /* Argument objects. */ 500{ 501 int allowAbbrev, index, index2, setError, i, result; 502 const char **argv; 503 static const char *tablePtr[] = {"a", "b", "check", NULL}; 504 /* 505 * Keep this structure declaration in sync with tclIndexObj.c 506 */ 507 struct IndexRep { 508 VOID *tablePtr; /* Pointer to the table of strings */ 509 int offset; /* Offset between table entries */ 510 int index; /* Selected index into table. */ 511 }; 512 struct IndexRep *indexRep; 513 514 if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), 515 "check") == 0)) { 516 /* 517 * This code checks to be sure that the results of Tcl_GetIndexFromObj 518 * are properly cached in the object and returned on subsequent 519 * lookups. 520 */ 521 522 if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { 523 return TCL_ERROR; 524 } 525 526 Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); 527 indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr; 528 indexRep->index = index2; 529 result = Tcl_GetIndexFromObj(NULL, objv[1], 530 tablePtr, "token", 0, &index); 531 if (result == TCL_OK) { 532 Tcl_SetIntObj(Tcl_GetObjResult(interp), index); 533 } 534 return result; 535 } 536 537 if (objc < 5) { 538 Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1); 539 return TCL_ERROR; 540 } 541 542 if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) { 543 return TCL_ERROR; 544 } 545 if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) { 546 return TCL_ERROR; 547 } 548 549 argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *))); 550 for (i = 4; i < objc; i++) { 551 argv[i-4] = Tcl_GetString(objv[i]); 552 } 553 argv[objc-4] = NULL; 554 555 /* 556 * Tcl_GetIndexFromObj assumes that the table is statically-allocated so 557 * that its address is different for each index object. If we accidently 558 * allocate a table at the same address as that cached in the index 559 * object, clear out the object's cached state. 560 */ 561 562 if ( objv[3]->typePtr != NULL 563 && !strcmp( "index", objv[3]->typePtr->name ) ) { 564 indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr; 565 if (indexRep->tablePtr == (VOID *) argv) { 566 objv[3]->typePtr->freeIntRepProc(objv[3]); 567 objv[3]->typePtr = NULL; 568 } 569 } 570 571 result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], 572 argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); 573 ckfree((char *) argv); 574 if (result == TCL_OK) { 575 Tcl_SetIntObj(Tcl_GetObjResult(interp), index); 576 } 577 return result; 578} 579 580/* 581 *---------------------------------------------------------------------- 582 * 583 * TestintobjCmd -- 584 * 585 * This function implements the "testintobj" command. It is used to 586 * test the int Tcl object type implementation. 587 * 588 * Results: 589 * A standard Tcl object result. 590 * 591 * Side effects: 592 * Creates and frees int objects, and also converts objects to 593 * have int type. 594 * 595 *---------------------------------------------------------------------- 596 */ 597 598static int 599TestintobjCmd( 600 ClientData clientData, /* Not used. */ 601 Tcl_Interp *interp, /* Current interpreter. */ 602 int objc, /* Number of arguments. */ 603 Tcl_Obj *const objv[]) /* Argument objects. */ 604{ 605 int intValue, varIndex, i; 606 long longValue; 607 char *index, *subCmd, *string; 608 609 if (objc < 3) { 610 wrongNumArgs: 611 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); 612 return TCL_ERROR; 613 } 614 615 index = Tcl_GetString(objv[2]); 616 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 617 return TCL_ERROR; 618 } 619 620 subCmd = Tcl_GetString(objv[1]); 621 if (strcmp(subCmd, "set") == 0) { 622 if (objc != 4) { 623 goto wrongNumArgs; 624 } 625 string = Tcl_GetString(objv[3]); 626 if (Tcl_GetInt(interp, string, &i) != TCL_OK) { 627 return TCL_ERROR; 628 } 629 intValue = i; 630 631 /* 632 * If the object currently bound to the variable with index varIndex 633 * has ref count 1 (i.e. the object is unshared) we can modify that 634 * object directly. Otherwise, if RC>1 (i.e. the object is shared), we 635 * must create a new object to modify/set and decrement the old 636 * formerly-shared object's ref count. This is "copy on write". 637 */ 638 639 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 640 Tcl_SetIntObj(varPtr[varIndex], intValue); 641 } else { 642 SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); 643 } 644 Tcl_SetObjResult(interp, varPtr[varIndex]); 645 } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ 646 if (objc != 4) { 647 goto wrongNumArgs; 648 } 649 string = Tcl_GetString(objv[3]); 650 if (Tcl_GetInt(interp, string, &i) != TCL_OK) { 651 return TCL_ERROR; 652 } 653 intValue = i; 654 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 655 Tcl_SetIntObj(varPtr[varIndex], intValue); 656 } else { 657 SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); 658 } 659 } else if (strcmp(subCmd, "setlong") == 0) { 660 if (objc != 4) { 661 goto wrongNumArgs; 662 } 663 string = Tcl_GetString(objv[3]); 664 if (Tcl_GetInt(interp, string, &i) != TCL_OK) { 665 return TCL_ERROR; 666 } 667 intValue = i; 668 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 669 Tcl_SetLongObj(varPtr[varIndex], intValue); 670 } else { 671 SetVarToObj(varIndex, Tcl_NewLongObj(intValue)); 672 } 673 Tcl_SetObjResult(interp, varPtr[varIndex]); 674 } else if (strcmp(subCmd, "setmaxlong") == 0) { 675 long maxLong = LONG_MAX; 676 if (objc != 3) { 677 goto wrongNumArgs; 678 } 679 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 680 Tcl_SetLongObj(varPtr[varIndex], maxLong); 681 } else { 682 SetVarToObj(varIndex, Tcl_NewLongObj(maxLong)); 683 } 684 } else if (strcmp(subCmd, "ismaxlong") == 0) { 685 if (objc != 3) { 686 goto wrongNumArgs; 687 } 688 if (CheckIfVarUnset(interp, varIndex)) { 689 return TCL_ERROR; 690 } 691 if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) { 692 return TCL_ERROR; 693 } 694 Tcl_AppendToObj(Tcl_GetObjResult(interp), 695 ((longValue == LONG_MAX)? "1" : "0"), -1); 696 } else if (strcmp(subCmd, "get") == 0) { 697 if (objc != 3) { 698 goto wrongNumArgs; 699 } 700 if (CheckIfVarUnset(interp, varIndex)) { 701 return TCL_ERROR; 702 } 703 Tcl_SetObjResult(interp, varPtr[varIndex]); 704 } else if (strcmp(subCmd, "get2") == 0) { 705 if (objc != 3) { 706 goto wrongNumArgs; 707 } 708 if (CheckIfVarUnset(interp, varIndex)) { 709 return TCL_ERROR; 710 } 711 string = Tcl_GetString(varPtr[varIndex]); 712 Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); 713 } else if (strcmp(subCmd, "inttoobigtest") == 0) { 714 /* 715 * If long ints have more bits than ints on this platform, verify that 716 * Tcl_GetIntFromObj returns an error if the long int held in an 717 * integer object's internal representation is too large to fit in an 718 * int. 719 */ 720 721 if (objc != 3) { 722 goto wrongNumArgs; 723 } 724#if (INT_MAX == LONG_MAX) /* int is same size as long int */ 725 Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); 726#else 727 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 728 Tcl_SetLongObj(varPtr[varIndex], LONG_MAX); 729 } else { 730 SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX)); 731 } 732 if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { 733 Tcl_ResetResult(interp); 734 Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); 735 return TCL_OK; 736 } 737 Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1); 738#endif 739 } else if (strcmp(subCmd, "mult10") == 0) { 740 if (objc != 3) { 741 goto wrongNumArgs; 742 } 743 if (CheckIfVarUnset(interp, varIndex)) { 744 return TCL_ERROR; 745 } 746 if (Tcl_GetIntFromObj(interp, varPtr[varIndex], 747 &intValue) != TCL_OK) { 748 return TCL_ERROR; 749 } 750 if (!Tcl_IsShared(varPtr[varIndex])) { 751 Tcl_SetIntObj(varPtr[varIndex], (intValue * 10)); 752 } else { 753 SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) )); 754 } 755 Tcl_SetObjResult(interp, varPtr[varIndex]); 756 } else if (strcmp(subCmd, "div10") == 0) { 757 if (objc != 3) { 758 goto wrongNumArgs; 759 } 760 if (CheckIfVarUnset(interp, varIndex)) { 761 return TCL_ERROR; 762 } 763 if (Tcl_GetIntFromObj(interp, varPtr[varIndex], 764 &intValue) != TCL_OK) { 765 return TCL_ERROR; 766 } 767 if (!Tcl_IsShared(varPtr[varIndex])) { 768 Tcl_SetIntObj(varPtr[varIndex], (intValue / 10)); 769 } else { 770 SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) )); 771 } 772 Tcl_SetObjResult(interp, varPtr[varIndex]); 773 } else { 774 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 775 "bad option \"", Tcl_GetString(objv[1]), 776 "\": must be set, get, get2, mult10, or div10", NULL); 777 return TCL_ERROR; 778 } 779 return TCL_OK; 780} 781 782/* 783 *----------------------------------------------------------------------------- 784 * 785 * TestlistobjCmd -- 786 * 787 * This function implements the 'testlistobj' command. It is used to 788 * test a few possible corner cases in list object manipulation from 789 * C code that cannot occur at the Tcl level. 790 * 791 * Results: 792 * A standard Tcl object result. 793 * 794 * Side effects: 795 * Creates, manipulates and frees list objects. 796 * 797 *----------------------------------------------------------------------------- 798 */ 799 800static int 801TestlistobjCmd( 802 ClientData clientData, /* Not used */ 803 Tcl_Interp *interp, /* Tcl interpreter */ 804 int objc, /* Number of arguments */ 805 Tcl_Obj *const objv[]) /* Argument objects */ 806{ 807 /* Subcommands supported by this command */ 808 const char* subcommands[] = { 809 "set", 810 "get", 811 "replace" 812 }; 813 enum listobjCmdIndex { 814 LISTOBJ_SET, 815 LISTOBJ_GET, 816 LISTOBJ_REPLACE 817 }; 818 819 const char* index; /* Argument giving the variable number */ 820 int varIndex; /* Variable number converted to binary */ 821 int cmdIndex; /* Ordinal number of the subcommand */ 822 int first; /* First index in the list */ 823 int count; /* Count of elements in a list */ 824 825 if (objc < 3) { 826 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); 827 return TCL_ERROR; 828 } 829 index = Tcl_GetString(objv[2]); 830 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 831 return TCL_ERROR; 832 } 833 if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", 834 0, &cmdIndex) != TCL_OK) { 835 return TCL_ERROR; 836 } 837 switch(cmdIndex) { 838 case LISTOBJ_SET: 839 if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { 840 Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3); 841 } else { 842 SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3)); 843 } 844 Tcl_SetObjResult(interp, varPtr[varIndex]); 845 break; 846 847 case LISTOBJ_GET: 848 if (objc != 3) { 849 Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); 850 return TCL_ERROR; 851 } 852 if (CheckIfVarUnset(interp, varIndex)) { 853 return TCL_ERROR; 854 } 855 Tcl_SetObjResult(interp, varPtr[varIndex]); 856 break; 857 858 case LISTOBJ_REPLACE: 859 if (objc < 5) { 860 Tcl_WrongNumArgs(interp, 2, objv, 861 "varIndex start count ?element...?"); 862 return TCL_ERROR; 863 } 864 if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK 865 || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) { 866 return TCL_ERROR; 867 } 868 if (Tcl_IsShared(varPtr[varIndex])) { 869 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); 870 } 871 Tcl_ResetResult(interp); 872 return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count, 873 objc-5, objv+5); 874 } 875 return TCL_OK; 876} 877 878/* 879 *---------------------------------------------------------------------- 880 * 881 * TestobjCmd -- 882 * 883 * This function implements the "testobj" command. It is used to test 884 * the type-independent portions of the Tcl object type implementation. 885 * 886 * Results: 887 * A standard Tcl object result. 888 * 889 * Side effects: 890 * Creates and frees objects. 891 * 892 *---------------------------------------------------------------------- 893 */ 894 895static int 896TestobjCmd( 897 ClientData clientData, /* Not used. */ 898 Tcl_Interp *interp, /* Current interpreter. */ 899 int objc, /* Number of arguments. */ 900 Tcl_Obj *const objv[]) /* Argument objects. */ 901{ 902 int varIndex, destIndex, i; 903 char *index, *subCmd, *string; 904 Tcl_ObjType *targetType; 905 906 if (objc < 2) { 907 wrongNumArgs: 908 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); 909 return TCL_ERROR; 910 } 911 912 subCmd = Tcl_GetString(objv[1]); 913 if (strcmp(subCmd, "assign") == 0) { 914 if (objc != 4) { 915 goto wrongNumArgs; 916 } 917 index = Tcl_GetString(objv[2]); 918 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 919 return TCL_ERROR; 920 } 921 if (CheckIfVarUnset(interp, varIndex)) { 922 return TCL_ERROR; 923 } 924 string = Tcl_GetString(objv[3]); 925 if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { 926 return TCL_ERROR; 927 } 928 SetVarToObj(destIndex, varPtr[varIndex]); 929 Tcl_SetObjResult(interp, varPtr[destIndex]); 930 } else if (strcmp(subCmd, "convert") == 0) { 931 char *typeName; 932 if (objc != 4) { 933 goto wrongNumArgs; 934 } 935 index = Tcl_GetString(objv[2]); 936 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 937 return TCL_ERROR; 938 } 939 if (CheckIfVarUnset(interp, varIndex)) { 940 return TCL_ERROR; 941 } 942 typeName = Tcl_GetString(objv[3]); 943 if ((targetType = Tcl_GetObjType(typeName)) == NULL) { 944 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 945 "no type ", typeName, " found", NULL); 946 return TCL_ERROR; 947 } 948 if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) 949 != TCL_OK) { 950 return TCL_ERROR; 951 } 952 Tcl_SetObjResult(interp, varPtr[varIndex]); 953 } else if (strcmp(subCmd, "duplicate") == 0) { 954 if (objc != 4) { 955 goto wrongNumArgs; 956 } 957 index = Tcl_GetString(objv[2]); 958 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 959 return TCL_ERROR; 960 } 961 if (CheckIfVarUnset(interp, varIndex)) { 962 return TCL_ERROR; 963 } 964 string = Tcl_GetString(objv[3]); 965 if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { 966 return TCL_ERROR; 967 } 968 SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); 969 Tcl_SetObjResult(interp, varPtr[destIndex]); 970 } else if (strcmp(subCmd, "freeallvars") == 0) { 971 if (objc != 2) { 972 goto wrongNumArgs; 973 } 974 for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { 975 if (varPtr[i] != NULL) { 976 Tcl_DecrRefCount(varPtr[i]); 977 varPtr[i] = NULL; 978 } 979 } 980 } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) { 981 if ( objc != 3 ) { 982 goto wrongNumArgs; 983 } 984 index = Tcl_GetString( objv[2] ); 985 if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) { 986 return TCL_ERROR; 987 } 988 if (CheckIfVarUnset(interp, varIndex)) { 989 return TCL_ERROR; 990 } 991 Tcl_InvalidateStringRep( varPtr[varIndex] ); 992 Tcl_SetObjResult( interp, varPtr[varIndex] ); 993 } else if (strcmp(subCmd, "newobj") == 0) { 994 if (objc != 3) { 995 goto wrongNumArgs; 996 } 997 index = Tcl_GetString(objv[2]); 998 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 999 return TCL_ERROR; 1000 } 1001 SetVarToObj(varIndex, Tcl_NewObj()); 1002 Tcl_SetObjResult(interp, varPtr[varIndex]); 1003 } else if (strcmp(subCmd, "objtype") == 0) { 1004 const char *typeName; 1005 1006 /* 1007 * return an object containing the name of the argument's type 1008 * of internal rep. If none exists, return "none". 1009 */ 1010 1011 if (objc != 3) { 1012 goto wrongNumArgs; 1013 } 1014 if (objv[2]->typePtr == NULL) { 1015 Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); 1016 } else { 1017 typeName = objv[2]->typePtr->name; 1018 Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); 1019 } 1020 } else if (strcmp(subCmd, "refcount") == 0) { 1021 char buf[TCL_INTEGER_SPACE]; 1022 1023 if (objc != 3) { 1024 goto wrongNumArgs; 1025 } 1026 index = Tcl_GetString(objv[2]); 1027 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 1028 return TCL_ERROR; 1029 } 1030 if (CheckIfVarUnset(interp, varIndex)) { 1031 return TCL_ERROR; 1032 } 1033 TclFormatInt(buf, varPtr[varIndex]->refCount); 1034 Tcl_SetResult(interp, buf, TCL_VOLATILE); 1035 } else if (strcmp(subCmd, "type") == 0) { 1036 if (objc != 3) { 1037 goto wrongNumArgs; 1038 } 1039 index = Tcl_GetString(objv[2]); 1040 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 1041 return TCL_ERROR; 1042 } 1043 if (CheckIfVarUnset(interp, varIndex)) { 1044 return TCL_ERROR; 1045 } 1046 if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ 1047 Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); 1048 } else { 1049 Tcl_AppendToObj(Tcl_GetObjResult(interp), 1050 varPtr[varIndex]->typePtr->name, -1); 1051 } 1052 } else if (strcmp(subCmd, "types") == 0) { 1053 if (objc != 2) { 1054 goto wrongNumArgs; 1055 } 1056 if (Tcl_AppendAllObjTypes(interp, 1057 Tcl_GetObjResult(interp)) != TCL_OK) { 1058 return TCL_ERROR; 1059 } 1060 } else { 1061 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1062 "bad option \"", Tcl_GetString(objv[1]), 1063 "\": must be assign, convert, duplicate, freeallvars, " 1064 "newobj, objcount, objtype, refcount, type, or types", NULL); 1065 return TCL_ERROR; 1066 } 1067 return TCL_OK; 1068} 1069 1070/* 1071 *---------------------------------------------------------------------- 1072 * 1073 * TeststringobjCmd -- 1074 * 1075 * This function implements the "teststringobj" command. It is used to 1076 * test the string Tcl object type implementation. 1077 * 1078 * Results: 1079 * A standard Tcl object result. 1080 * 1081 * Side effects: 1082 * Creates and frees string objects, and also converts objects to 1083 * have string type. 1084 * 1085 *---------------------------------------------------------------------- 1086 */ 1087 1088static int 1089TeststringobjCmd( 1090 ClientData clientData, /* Not used. */ 1091 Tcl_Interp *interp, /* Current interpreter. */ 1092 int objc, /* Number of arguments. */ 1093 Tcl_Obj *const objv[]) /* Argument objects. */ 1094{ 1095 int varIndex, option, i, length; 1096 Tcl_UniChar *unicode; 1097#define MAX_STRINGS 11 1098 char *index, *string, *strings[MAX_STRINGS+1]; 1099 TestString *strPtr; 1100 static const char *options[] = { 1101 "append", "appendstrings", "get", "get2", "length", "length2", 1102 "set", "set2", "setlength", "ualloc", "getunicode", 1103 "appendself", "appendself2", NULL 1104 }; 1105 1106 if (objc < 3) { 1107 wrongNumArgs: 1108 Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); 1109 return TCL_ERROR; 1110 } 1111 1112 index = Tcl_GetString(objv[2]); 1113 if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { 1114 return TCL_ERROR; 1115 } 1116 1117 if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option) 1118 != TCL_OK) { 1119 return TCL_ERROR; 1120 } 1121 switch (option) { 1122 case 0: /* append */ 1123 if (objc != 5) { 1124 goto wrongNumArgs; 1125 } 1126 if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { 1127 return TCL_ERROR; 1128 } 1129 if (varPtr[varIndex] == NULL) { 1130 SetVarToObj(varIndex, Tcl_NewObj()); 1131 } 1132 1133 /* 1134 * If the object bound to variable "varIndex" is shared, we must 1135 * "copy on write" and append to a copy of the object. 1136 */ 1137 1138 if (Tcl_IsShared(varPtr[varIndex])) { 1139 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); 1140 } 1141 string = Tcl_GetString(objv[3]); 1142 Tcl_AppendToObj(varPtr[varIndex], string, length); 1143 Tcl_SetObjResult(interp, varPtr[varIndex]); 1144 break; 1145 case 1: /* appendstrings */ 1146 if (objc > (MAX_STRINGS+3)) { 1147 goto wrongNumArgs; 1148 } 1149 if (varPtr[varIndex] == NULL) { 1150 SetVarToObj(varIndex, Tcl_NewObj()); 1151 } 1152 1153 /* 1154 * If the object bound to variable "varIndex" is shared, we must 1155 * "copy on write" and append to a copy of the object. 1156 */ 1157 1158 if (Tcl_IsShared(varPtr[varIndex])) { 1159 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); 1160 } 1161 for (i = 3; i < objc; i++) { 1162 strings[i-3] = Tcl_GetString(objv[i]); 1163 } 1164 for ( ; i < 12 + 3; i++) { 1165 strings[i - 3] = NULL; 1166 } 1167 Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1], 1168 strings[2], strings[3], strings[4], strings[5], 1169 strings[6], strings[7], strings[8], strings[9], 1170 strings[10], strings[11]); 1171 Tcl_SetObjResult(interp, varPtr[varIndex]); 1172 break; 1173 case 2: /* get */ 1174 if (objc != 3) { 1175 goto wrongNumArgs; 1176 } 1177 if (CheckIfVarUnset(interp, varIndex)) { 1178 return TCL_ERROR; 1179 } 1180 Tcl_SetObjResult(interp, varPtr[varIndex]); 1181 break; 1182 case 3: /* get2 */ 1183 if (objc != 3) { 1184 goto wrongNumArgs; 1185 } 1186 if (CheckIfVarUnset(interp, varIndex)) { 1187 return TCL_ERROR; 1188 } 1189 string = Tcl_GetString(varPtr[varIndex]); 1190 Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); 1191 break; 1192 case 4: /* length */ 1193 if (objc != 3) { 1194 goto wrongNumArgs; 1195 } 1196 Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) 1197 ? varPtr[varIndex]->length : -1); 1198 break; 1199 case 5: /* length2 */ 1200 if (objc != 3) { 1201 goto wrongNumArgs; 1202 } 1203 if (varPtr[varIndex] != NULL) { 1204 strPtr = (TestString *) 1205 (varPtr[varIndex])->internalRep.otherValuePtr; 1206 length = (int) strPtr->allocated; 1207 } else { 1208 length = -1; 1209 } 1210 Tcl_SetIntObj(Tcl_GetObjResult(interp), length); 1211 break; 1212 case 6: /* set */ 1213 if (objc != 4) { 1214 goto wrongNumArgs; 1215 } 1216 1217 /* 1218 * If the object currently bound to the variable with index 1219 * varIndex has ref count 1 (i.e. the object is unshared) we can 1220 * modify that object directly. Otherwise, if RC>1 (i.e. the 1221 * object is shared), we must create a new object to modify/set 1222 * and decrement the old formerly-shared object's ref count. This 1223 * is "copy on write". 1224 */ 1225 1226 string = Tcl_GetStringFromObj(objv[3], &length); 1227 if ((varPtr[varIndex] != NULL) 1228 && !Tcl_IsShared(varPtr[varIndex])) { 1229 Tcl_SetStringObj(varPtr[varIndex], string, length); 1230 } else { 1231 SetVarToObj(varIndex, Tcl_NewStringObj(string, length)); 1232 } 1233 Tcl_SetObjResult(interp, varPtr[varIndex]); 1234 break; 1235 case 7: /* set2 */ 1236 if (objc != 4) { 1237 goto wrongNumArgs; 1238 } 1239 SetVarToObj(varIndex, objv[3]); 1240 break; 1241 case 8: /* setlength */ 1242 if (objc != 4) { 1243 goto wrongNumArgs; 1244 } 1245 if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) { 1246 return TCL_ERROR; 1247 } 1248 if (varPtr[varIndex] != NULL) { 1249 Tcl_SetObjLength(varPtr[varIndex], length); 1250 } 1251 break; 1252 case 9: /* ualloc */ 1253 if (objc != 3) { 1254 goto wrongNumArgs; 1255 } 1256 if (varPtr[varIndex] != NULL) { 1257 strPtr = (TestString *) 1258 (varPtr[varIndex])->internalRep.otherValuePtr; 1259 length = (int) strPtr->uallocated; 1260 } else { 1261 length = -1; 1262 } 1263 Tcl_SetIntObj(Tcl_GetObjResult(interp), length); 1264 break; 1265 case 10: /* getunicode */ 1266 if (objc != 3) { 1267 goto wrongNumArgs; 1268 } 1269 Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL); 1270 break; 1271 case 11: /* appendself */ 1272 if (objc != 4) { 1273 goto wrongNumArgs; 1274 } 1275 if (varPtr[varIndex] == NULL) { 1276 SetVarToObj(varIndex, Tcl_NewObj()); 1277 } 1278 1279 /* 1280 * If the object bound to variable "varIndex" is shared, we must 1281 * "copy on write" and append to a copy of the object. 1282 */ 1283 1284 if (Tcl_IsShared(varPtr[varIndex])) { 1285 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); 1286 } 1287 1288 string = Tcl_GetStringFromObj(varPtr[varIndex], &length); 1289 1290 if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { 1291 return TCL_ERROR; 1292 } 1293 if ((i < 0) || (i > length)) { 1294 Tcl_SetObjResult(interp, Tcl_NewStringObj( 1295 "index value out of range", -1)); 1296 return TCL_ERROR; 1297 } 1298 1299 Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); 1300 Tcl_SetObjResult(interp, varPtr[varIndex]); 1301 break; 1302 case 12: /* appendself2 */ 1303 if (objc != 4) { 1304 goto wrongNumArgs; 1305 } 1306 if (varPtr[varIndex] == NULL) { 1307 SetVarToObj(varIndex, Tcl_NewObj()); 1308 } 1309 1310 /* 1311 * If the object bound to variable "varIndex" is shared, we must 1312 * "copy on write" and append to a copy of the object. 1313 */ 1314 1315 if (Tcl_IsShared(varPtr[varIndex])) { 1316 SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); 1317 } 1318 1319 unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length); 1320 1321 if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { 1322 return TCL_ERROR; 1323 } 1324 if ((i < 0) || (i > length)) { 1325 Tcl_SetObjResult(interp, Tcl_NewStringObj( 1326 "index value out of range", -1)); 1327 return TCL_ERROR; 1328 } 1329 1330 Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i); 1331 Tcl_SetObjResult(interp, varPtr[varIndex]); 1332 break; 1333 } 1334 1335 return TCL_OK; 1336} 1337 1338/* 1339 *---------------------------------------------------------------------- 1340 * 1341 * SetVarToObj -- 1342 * 1343 * Utility routine to assign a Tcl_Obj* to a test variable. The 1344 * Tcl_Obj* can be NULL. 1345 * 1346 * Results: 1347 * None. 1348 * 1349 * Side effects: 1350 * This routine handles ref counting details for assignment: i.e. the old 1351 * value's ref count must be decremented (if not NULL) and the new one 1352 * incremented (also if not NULL). 1353 * 1354 *---------------------------------------------------------------------- 1355 */ 1356 1357static void 1358SetVarToObj( 1359 int varIndex, /* Designates the assignment variable. */ 1360 Tcl_Obj *objPtr) /* Points to object to assign to var. */ 1361{ 1362 if (varPtr[varIndex] != NULL) { 1363 Tcl_DecrRefCount(varPtr[varIndex]); 1364 } 1365 varPtr[varIndex] = objPtr; 1366 if (objPtr != NULL) { 1367 Tcl_IncrRefCount(objPtr); 1368 } 1369} 1370 1371/* 1372 *---------------------------------------------------------------------- 1373 * 1374 * GetVariableIndex -- 1375 * 1376 * Utility routine to get a test variable index from the command line. 1377 * 1378 * Results: 1379 * A standard Tcl object result. 1380 * 1381 * Side effects: 1382 * None. 1383 * 1384 *---------------------------------------------------------------------- 1385 */ 1386 1387static int 1388GetVariableIndex( 1389 Tcl_Interp *interp, /* Interpreter for error reporting. */ 1390 const char *string, /* String containing a variable index 1391 * specified as a nonnegative number less than 1392 * NUMBER_OF_OBJECT_VARS. */ 1393 int *indexPtr) /* Place to store converted result. */ 1394{ 1395 int index; 1396 1397 if (Tcl_GetInt(interp, string, &index) != TCL_OK) { 1398 return TCL_ERROR; 1399 } 1400 if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) { 1401 Tcl_ResetResult(interp); 1402 Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1); 1403 return TCL_ERROR; 1404 } 1405 1406 *indexPtr = index; 1407 return TCL_OK; 1408} 1409 1410/* 1411 *---------------------------------------------------------------------- 1412 * 1413 * CheckIfVarUnset -- 1414 * 1415 * Utility function that checks whether a test variable is readable: 1416 * i.e., that varPtr[varIndex] is non-NULL. 1417 * 1418 * Results: 1419 * 1 if the test variable is unset (NULL); 0 otherwise. 1420 * 1421 * Side effects: 1422 * Sets the interpreter result to an error message if the variable is 1423 * unset (NULL). 1424 * 1425 *---------------------------------------------------------------------- 1426 */ 1427 1428static int 1429CheckIfVarUnset( 1430 Tcl_Interp *interp, /* Interpreter for error reporting. */ 1431 int varIndex) /* Index of the test variable to check. */ 1432{ 1433 if (varPtr[varIndex] == NULL) { 1434 char buf[32 + TCL_INTEGER_SPACE]; 1435 1436 sprintf(buf, "variable %d is unset (NULL)", varIndex); 1437 Tcl_ResetResult(interp); 1438 Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); 1439 return 1; 1440 } 1441 return 0; 1442} 1443 1444/* 1445 * Local Variables: 1446 * mode: c 1447 * c-basic-offset: 4 1448 * fill-column: 78 1449 * End: 1450 */ 1451