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