os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclTestObj.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclTestObj.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1192 @@
1.4 +/*
1.5 + * tclTestObj.c --
1.6 + *
1.7 + * This file contains C command procedures for the additional Tcl
1.8 + * commands that are used for testing implementations of the Tcl object
1.9 + * types. These commands are not normally included in Tcl
1.10 + * applications; they're only used for testing.
1.11 + *
1.12 + * Copyright (c) 1995-1998 Sun Microsystems, Inc.
1.13 + * Copyright (c) 1999 by Scriptics Corporation.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclTestObj.c,v 1.12 2002/12/04 13:09:24 vincentdarley Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +
1.23 +/*
1.24 + * An array of Tcl_Obj pointers used in the commands that operate on or get
1.25 + * the values of Tcl object-valued variables. varPtr[i] is the i-th
1.26 + * variable's Tcl_Obj *.
1.27 + */
1.28 +
1.29 +#define NUMBER_OF_OBJECT_VARS 20
1.30 +static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
1.31 +
1.32 +/*
1.33 + * Forward declarations for procedures defined later in this file:
1.34 + */
1.35 +
1.36 +static int CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
1.37 + int varIndex));
1.38 +static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
1.39 + char *string, int *indexPtr));
1.40 +static void SetVarToObj _ANSI_ARGS_((int varIndex,
1.41 + Tcl_Obj *objPtr));
1.42 +int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
1.43 +static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
1.44 + Tcl_Interp *interp, int objc,
1.45 + Tcl_Obj *CONST objv[]));
1.46 +static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
1.47 + Tcl_Interp *interp, int objc,
1.48 + Tcl_Obj *CONST objv[]));
1.49 +static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
1.50 + Tcl_Interp *interp, int objc,
1.51 + Tcl_Obj *CONST objv[]));
1.52 +static int TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
1.53 + Tcl_Interp *interp, int objc,
1.54 + Tcl_Obj *CONST objv[]));
1.55 +static int TestintobjCmd _ANSI_ARGS_((ClientData dummy,
1.56 + Tcl_Interp *interp, int objc,
1.57 + Tcl_Obj *CONST objv[]));
1.58 +static int TestobjCmd _ANSI_ARGS_((ClientData dummy,
1.59 + Tcl_Interp *interp, int objc,
1.60 + Tcl_Obj *CONST objv[]));
1.61 +static int TeststringobjCmd _ANSI_ARGS_((ClientData dummy,
1.62 + Tcl_Interp *interp, int objc,
1.63 + Tcl_Obj *CONST objv[]));
1.64 +
1.65 +typedef struct TestString {
1.66 + int numChars;
1.67 + size_t allocated;
1.68 + size_t uallocated;
1.69 + Tcl_UniChar unicode[2];
1.70 +} TestString;
1.71 +
1.72 +
1.73 +/*
1.74 + *----------------------------------------------------------------------
1.75 + *
1.76 + * TclObjTest_Init --
1.77 + *
1.78 + * This procedure creates additional commands that are used to test the
1.79 + * Tcl object support.
1.80 + *
1.81 + * Results:
1.82 + * Returns a standard Tcl completion code, and leaves an error
1.83 + * message in the interp's result if an error occurs.
1.84 + *
1.85 + * Side effects:
1.86 + * Creates and registers several new testing commands.
1.87 + *
1.88 + *----------------------------------------------------------------------
1.89 + */
1.90 +
1.91 +int
1.92 +TclObjTest_Init(interp)
1.93 + Tcl_Interp *interp;
1.94 +{
1.95 + register int i;
1.96 +
1.97 + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
1.98 + varPtr[i] = NULL;
1.99 + }
1.100 +
1.101 + Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
1.102 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.103 + Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
1.104 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.105 + Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
1.106 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.107 + Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
1.108 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.109 + Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
1.110 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.111 + Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
1.112 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.113 + Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
1.114 + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
1.115 + return TCL_OK;
1.116 +}
1.117 +
1.118 +/*
1.119 + *----------------------------------------------------------------------
1.120 + *
1.121 + * TestbooleanobjCmd --
1.122 + *
1.123 + * This procedure implements the "testbooleanobj" command. It is used
1.124 + * to test the boolean Tcl object type implementation.
1.125 + *
1.126 + * Results:
1.127 + * A standard Tcl object result.
1.128 + *
1.129 + * Side effects:
1.130 + * Creates and frees boolean objects, and also converts objects to
1.131 + * have boolean type.
1.132 + *
1.133 + *----------------------------------------------------------------------
1.134 + */
1.135 +
1.136 +static int
1.137 +TestbooleanobjCmd(clientData, interp, objc, objv)
1.138 + ClientData clientData; /* Not used. */
1.139 + Tcl_Interp *interp; /* Current interpreter. */
1.140 + int objc; /* Number of arguments. */
1.141 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.142 +{
1.143 + int varIndex, boolValue;
1.144 + char *index, *subCmd;
1.145 +
1.146 + if (objc < 3) {
1.147 + wrongNumArgs:
1.148 + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1.149 + return TCL_ERROR;
1.150 + }
1.151 +
1.152 + index = Tcl_GetString(objv[2]);
1.153 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.154 + return TCL_ERROR;
1.155 + }
1.156 +
1.157 + subCmd = Tcl_GetString(objv[1]);
1.158 + if (strcmp(subCmd, "set") == 0) {
1.159 + if (objc != 4) {
1.160 + goto wrongNumArgs;
1.161 + }
1.162 + if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
1.163 + return TCL_ERROR;
1.164 + }
1.165 +
1.166 + /*
1.167 + * If the object currently bound to the variable with index varIndex
1.168 + * has ref count 1 (i.e. the object is unshared) we can modify that
1.169 + * object directly. Otherwise, if RC>1 (i.e. the object is shared),
1.170 + * we must create a new object to modify/set and decrement the old
1.171 + * formerly-shared object's ref count. This is "copy on write".
1.172 + */
1.173 +
1.174 + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
1.175 + Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
1.176 + } else {
1.177 + SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
1.178 + }
1.179 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.180 + } else if (strcmp(subCmd, "get") == 0) {
1.181 + if (objc != 3) {
1.182 + goto wrongNumArgs;
1.183 + }
1.184 + if (CheckIfVarUnset(interp, varIndex)) {
1.185 + return TCL_ERROR;
1.186 + }
1.187 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.188 + } else if (strcmp(subCmd, "not") == 0) {
1.189 + if (objc != 3) {
1.190 + goto wrongNumArgs;
1.191 + }
1.192 + if (CheckIfVarUnset(interp, varIndex)) {
1.193 + return TCL_ERROR;
1.194 + }
1.195 + if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
1.196 + &boolValue) != TCL_OK) {
1.197 + return TCL_ERROR;
1.198 + }
1.199 + if (!Tcl_IsShared(varPtr[varIndex])) {
1.200 + Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
1.201 + } else {
1.202 + SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
1.203 + }
1.204 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.205 + } else {
1.206 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.207 + "bad option \"", Tcl_GetString(objv[1]),
1.208 + "\": must be set, get, or not", (char *) NULL);
1.209 + return TCL_ERROR;
1.210 + }
1.211 + return TCL_OK;
1.212 +}
1.213 +
1.214 +/*
1.215 + *----------------------------------------------------------------------
1.216 + *
1.217 + * TestconvertobjCmd --
1.218 + *
1.219 + * This procedure implements the "testconvertobj" command. It is used
1.220 + * to test converting objects to new types.
1.221 + *
1.222 + * Results:
1.223 + * A standard Tcl object result.
1.224 + *
1.225 + * Side effects:
1.226 + * Converts objects to new types.
1.227 + *
1.228 + *----------------------------------------------------------------------
1.229 + */
1.230 +
1.231 +static int
1.232 +TestconvertobjCmd(clientData, interp, objc, objv)
1.233 + ClientData clientData; /* Not used. */
1.234 + Tcl_Interp *interp; /* Current interpreter. */
1.235 + int objc; /* Number of arguments. */
1.236 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.237 +{
1.238 + char *subCmd;
1.239 + char buf[20];
1.240 +
1.241 + if (objc < 3) {
1.242 + wrongNumArgs:
1.243 + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1.244 + return TCL_ERROR;
1.245 + }
1.246 +
1.247 + subCmd = Tcl_GetString(objv[1]);
1.248 + if (strcmp(subCmd, "double") == 0) {
1.249 + double d;
1.250 +
1.251 + if (objc != 3) {
1.252 + goto wrongNumArgs;
1.253 + }
1.254 + if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {
1.255 + return TCL_ERROR;
1.256 + }
1.257 + sprintf(buf, "%f", d);
1.258 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1.259 + } else {
1.260 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.261 + "bad option \"", Tcl_GetString(objv[1]),
1.262 + "\": must be double", (char *) NULL);
1.263 + return TCL_ERROR;
1.264 + }
1.265 + return TCL_OK;
1.266 +}
1.267 +
1.268 +/*
1.269 + *----------------------------------------------------------------------
1.270 + *
1.271 + * TestdoubleobjCmd --
1.272 + *
1.273 + * This procedure implements the "testdoubleobj" command. It is used
1.274 + * to test the double-precision floating point Tcl object type
1.275 + * implementation.
1.276 + *
1.277 + * Results:
1.278 + * A standard Tcl object result.
1.279 + *
1.280 + * Side effects:
1.281 + * Creates and frees double objects, and also converts objects to
1.282 + * have double type.
1.283 + *
1.284 + *----------------------------------------------------------------------
1.285 + */
1.286 +
1.287 +static int
1.288 +TestdoubleobjCmd(clientData, interp, objc, objv)
1.289 + ClientData clientData; /* Not used. */
1.290 + Tcl_Interp *interp; /* Current interpreter. */
1.291 + int objc; /* Number of arguments. */
1.292 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.293 +{
1.294 + int varIndex;
1.295 + double doubleValue;
1.296 + char *index, *subCmd, *string;
1.297 +
1.298 + if (objc < 3) {
1.299 + wrongNumArgs:
1.300 + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1.301 + return TCL_ERROR;
1.302 + }
1.303 +
1.304 + index = Tcl_GetString(objv[2]);
1.305 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.306 + return TCL_ERROR;
1.307 + }
1.308 +
1.309 + subCmd = Tcl_GetString(objv[1]);
1.310 + if (strcmp(subCmd, "set") == 0) {
1.311 + if (objc != 4) {
1.312 + goto wrongNumArgs;
1.313 + }
1.314 + string = Tcl_GetString(objv[3]);
1.315 + if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
1.316 + return TCL_ERROR;
1.317 + }
1.318 +
1.319 + /*
1.320 + * If the object currently bound to the variable with index varIndex
1.321 + * has ref count 1 (i.e. the object is unshared) we can modify that
1.322 + * object directly. Otherwise, if RC>1 (i.e. the object is shared),
1.323 + * we must create a new object to modify/set and decrement the old
1.324 + * formerly-shared object's ref count. This is "copy on write".
1.325 + */
1.326 +
1.327 + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
1.328 + Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
1.329 + } else {
1.330 + SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
1.331 + }
1.332 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.333 + } else if (strcmp(subCmd, "get") == 0) {
1.334 + if (objc != 3) {
1.335 + goto wrongNumArgs;
1.336 + }
1.337 + if (CheckIfVarUnset(interp, varIndex)) {
1.338 + return TCL_ERROR;
1.339 + }
1.340 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.341 + } else if (strcmp(subCmd, "mult10") == 0) {
1.342 + if (objc != 3) {
1.343 + goto wrongNumArgs;
1.344 + }
1.345 + if (CheckIfVarUnset(interp, varIndex)) {
1.346 + return TCL_ERROR;
1.347 + }
1.348 + if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
1.349 + &doubleValue) != TCL_OK) {
1.350 + return TCL_ERROR;
1.351 + }
1.352 + if (!Tcl_IsShared(varPtr[varIndex])) {
1.353 + Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
1.354 + } else {
1.355 + SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
1.356 + }
1.357 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.358 + } else if (strcmp(subCmd, "div10") == 0) {
1.359 + if (objc != 3) {
1.360 + goto wrongNumArgs;
1.361 + }
1.362 + if (CheckIfVarUnset(interp, varIndex)) {
1.363 + return TCL_ERROR;
1.364 + }
1.365 + if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
1.366 + &doubleValue) != TCL_OK) {
1.367 + return TCL_ERROR;
1.368 + }
1.369 + if (!Tcl_IsShared(varPtr[varIndex])) {
1.370 + Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
1.371 + } else {
1.372 + SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
1.373 + }
1.374 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.375 + } else {
1.376 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.377 + "bad option \"", Tcl_GetString(objv[1]),
1.378 + "\": must be set, get, mult10, or div10", (char *) NULL);
1.379 + return TCL_ERROR;
1.380 + }
1.381 + return TCL_OK;
1.382 +}
1.383 +
1.384 +/*
1.385 + *----------------------------------------------------------------------
1.386 + *
1.387 + * TestindexobjCmd --
1.388 + *
1.389 + * This procedure implements the "testindexobj" command. It is used to
1.390 + * test the index Tcl object type implementation.
1.391 + *
1.392 + * Results:
1.393 + * A standard Tcl object result.
1.394 + *
1.395 + * Side effects:
1.396 + * Creates and frees int objects, and also converts objects to
1.397 + * have int type.
1.398 + *
1.399 + *----------------------------------------------------------------------
1.400 + */
1.401 +
1.402 +static int
1.403 +TestindexobjCmd(clientData, interp, objc, objv)
1.404 + ClientData clientData; /* Not used. */
1.405 + Tcl_Interp *interp; /* Current interpreter. */
1.406 + int objc; /* Number of arguments. */
1.407 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.408 +{
1.409 + int allowAbbrev, index, index2, setError, i, result;
1.410 + CONST char **argv;
1.411 + static CONST char *tablePtr[] = {"a", "b", "check", (char *) NULL};
1.412 + /*
1.413 + * Keep this structure declaration in sync with tclIndexObj.c
1.414 + */
1.415 + struct IndexRep {
1.416 + VOID *tablePtr; /* Pointer to the table of strings */
1.417 + int offset; /* Offset between table entries */
1.418 + int index; /* Selected index into table. */
1.419 + };
1.420 + struct IndexRep *indexRep;
1.421 +
1.422 + if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
1.423 + "check") == 0)) {
1.424 + /*
1.425 + * This code checks to be sure that the results of
1.426 + * Tcl_GetIndexFromObj are properly cached in the object and
1.427 + * returned on subsequent lookups.
1.428 + */
1.429 +
1.430 + if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
1.431 + return TCL_ERROR;
1.432 + }
1.433 +
1.434 + Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
1.435 + "token", 0, &index);
1.436 + indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
1.437 + indexRep->index = index2;
1.438 + result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
1.439 + tablePtr, "token", 0, &index);
1.440 + if (result == TCL_OK) {
1.441 + Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
1.442 + }
1.443 + return result;
1.444 + }
1.445 +
1.446 + if (objc < 5) {
1.447 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
1.448 + return TCL_ERROR;
1.449 + }
1.450 +
1.451 + if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
1.452 + return TCL_ERROR;
1.453 + }
1.454 + if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
1.455 + return TCL_ERROR;
1.456 + }
1.457 +
1.458 + argv = (CONST char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
1.459 + for (i = 4; i < objc; i++) {
1.460 + argv[i-4] = Tcl_GetString(objv[i]);
1.461 + }
1.462 + argv[objc-4] = NULL;
1.463 +
1.464 + /*
1.465 + * Tcl_GetIndexFromObj assumes that the table is statically-allocated
1.466 + * so that its address is different for each index object. If we
1.467 + * accidently allocate a table at the same address as that cached in
1.468 + * the index object, clear out the object's cached state.
1.469 + */
1.470 +
1.471 + if ( objv[3]->typePtr != NULL
1.472 + && !strcmp( "index", objv[3]->typePtr->name ) ) {
1.473 + indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
1.474 + if (indexRep->tablePtr == (VOID *) argv) {
1.475 + objv[3]->typePtr->freeIntRepProc(objv[3]);
1.476 + objv[3]->typePtr = NULL;
1.477 + }
1.478 + }
1.479 +
1.480 + result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
1.481 + argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
1.482 + ckfree((char *) argv);
1.483 + if (result == TCL_OK) {
1.484 + Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
1.485 + }
1.486 + return result;
1.487 +}
1.488 +
1.489 +/*
1.490 + *----------------------------------------------------------------------
1.491 + *
1.492 + * TestintobjCmd --
1.493 + *
1.494 + * This procedure implements the "testintobj" command. It is used to
1.495 + * test the int Tcl object type implementation.
1.496 + *
1.497 + * Results:
1.498 + * A standard Tcl object result.
1.499 + *
1.500 + * Side effects:
1.501 + * Creates and frees int objects, and also converts objects to
1.502 + * have int type.
1.503 + *
1.504 + *----------------------------------------------------------------------
1.505 + */
1.506 +
1.507 +static int
1.508 +TestintobjCmd(clientData, interp, objc, objv)
1.509 + ClientData clientData; /* Not used. */
1.510 + Tcl_Interp *interp; /* Current interpreter. */
1.511 + int objc; /* Number of arguments. */
1.512 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.513 +{
1.514 + int intValue, varIndex, i;
1.515 + long longValue;
1.516 + char *index, *subCmd, *string;
1.517 +
1.518 + if (objc < 3) {
1.519 + wrongNumArgs:
1.520 + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1.521 + return TCL_ERROR;
1.522 + }
1.523 +
1.524 + index = Tcl_GetString(objv[2]);
1.525 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.526 + return TCL_ERROR;
1.527 + }
1.528 +
1.529 + subCmd = Tcl_GetString(objv[1]);
1.530 + if (strcmp(subCmd, "set") == 0) {
1.531 + if (objc != 4) {
1.532 + goto wrongNumArgs;
1.533 + }
1.534 + string = Tcl_GetString(objv[3]);
1.535 + if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
1.536 + return TCL_ERROR;
1.537 + }
1.538 + intValue = i;
1.539 +
1.540 + /*
1.541 + * If the object currently bound to the variable with index varIndex
1.542 + * has ref count 1 (i.e. the object is unshared) we can modify that
1.543 + * object directly. Otherwise, if RC>1 (i.e. the object is shared),
1.544 + * we must create a new object to modify/set and decrement the old
1.545 + * formerly-shared object's ref count. This is "copy on write".
1.546 + */
1.547 +
1.548 + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
1.549 + Tcl_SetIntObj(varPtr[varIndex], intValue);
1.550 + } else {
1.551 + SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
1.552 + }
1.553 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.554 + } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
1.555 + if (objc != 4) {
1.556 + goto wrongNumArgs;
1.557 + }
1.558 + string = Tcl_GetString(objv[3]);
1.559 + if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
1.560 + return TCL_ERROR;
1.561 + }
1.562 + intValue = i;
1.563 + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
1.564 + Tcl_SetIntObj(varPtr[varIndex], intValue);
1.565 + } else {
1.566 + SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
1.567 + }
1.568 + } else if (strcmp(subCmd, "setlong") == 0) {
1.569 + if (objc != 4) {
1.570 + goto wrongNumArgs;
1.571 + }
1.572 + string = Tcl_GetString(objv[3]);
1.573 + if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
1.574 + return TCL_ERROR;
1.575 + }
1.576 + intValue = i;
1.577 + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
1.578 + Tcl_SetLongObj(varPtr[varIndex], intValue);
1.579 + } else {
1.580 + SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
1.581 + }
1.582 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.583 + } else if (strcmp(subCmd, "setmaxlong") == 0) {
1.584 + long maxLong = LONG_MAX;
1.585 + if (objc != 3) {
1.586 + goto wrongNumArgs;
1.587 + }
1.588 + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
1.589 + Tcl_SetLongObj(varPtr[varIndex], maxLong);
1.590 + } else {
1.591 + SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
1.592 + }
1.593 + } else if (strcmp(subCmd, "ismaxlong") == 0) {
1.594 + if (objc != 3) {
1.595 + goto wrongNumArgs;
1.596 + }
1.597 + if (CheckIfVarUnset(interp, varIndex)) {
1.598 + return TCL_ERROR;
1.599 + }
1.600 + if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
1.601 + return TCL_ERROR;
1.602 + }
1.603 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.604 + ((longValue == LONG_MAX)? "1" : "0"), -1);
1.605 + } else if (strcmp(subCmd, "get") == 0) {
1.606 + if (objc != 3) {
1.607 + goto wrongNumArgs;
1.608 + }
1.609 + if (CheckIfVarUnset(interp, varIndex)) {
1.610 + return TCL_ERROR;
1.611 + }
1.612 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.613 + } else if (strcmp(subCmd, "get2") == 0) {
1.614 + if (objc != 3) {
1.615 + goto wrongNumArgs;
1.616 + }
1.617 + if (CheckIfVarUnset(interp, varIndex)) {
1.618 + return TCL_ERROR;
1.619 + }
1.620 + string = Tcl_GetString(varPtr[varIndex]);
1.621 + Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
1.622 + } else if (strcmp(subCmd, "inttoobigtest") == 0) {
1.623 + /*
1.624 + * If long ints have more bits than ints on this platform, verify
1.625 + * that Tcl_GetIntFromObj returns an error if the long int held
1.626 + * in an integer object's internal representation is too large
1.627 + * to fit in an int.
1.628 + */
1.629 +
1.630 + if (objc != 3) {
1.631 + goto wrongNumArgs;
1.632 + }
1.633 +#if (INT_MAX == LONG_MAX) /* int is same size as long int */
1.634 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
1.635 +#else
1.636 + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
1.637 + Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
1.638 + } else {
1.639 + SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
1.640 + }
1.641 + if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
1.642 + Tcl_ResetResult(interp);
1.643 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
1.644 + return TCL_OK;
1.645 + }
1.646 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
1.647 +#endif
1.648 + } else if (strcmp(subCmd, "mult10") == 0) {
1.649 + if (objc != 3) {
1.650 + goto wrongNumArgs;
1.651 + }
1.652 + if (CheckIfVarUnset(interp, varIndex)) {
1.653 + return TCL_ERROR;
1.654 + }
1.655 + if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
1.656 + &intValue) != TCL_OK) {
1.657 + return TCL_ERROR;
1.658 + }
1.659 + if (!Tcl_IsShared(varPtr[varIndex])) {
1.660 + Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
1.661 + } else {
1.662 + SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
1.663 + }
1.664 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.665 + } else if (strcmp(subCmd, "div10") == 0) {
1.666 + if (objc != 3) {
1.667 + goto wrongNumArgs;
1.668 + }
1.669 + if (CheckIfVarUnset(interp, varIndex)) {
1.670 + return TCL_ERROR;
1.671 + }
1.672 + if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
1.673 + &intValue) != TCL_OK) {
1.674 + return TCL_ERROR;
1.675 + }
1.676 + if (!Tcl_IsShared(varPtr[varIndex])) {
1.677 + Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
1.678 + } else {
1.679 + SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
1.680 + }
1.681 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.682 + } else {
1.683 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.684 + "bad option \"", Tcl_GetString(objv[1]),
1.685 + "\": must be set, get, get2, mult10, or div10",
1.686 + (char *) NULL);
1.687 + return TCL_ERROR;
1.688 + }
1.689 + return TCL_OK;
1.690 +}
1.691 +
1.692 +/*
1.693 + *----------------------------------------------------------------------
1.694 + *
1.695 + * TestobjCmd --
1.696 + *
1.697 + * This procedure implements the "testobj" command. It is used to test
1.698 + * the type-independent portions of the Tcl object type implementation.
1.699 + *
1.700 + * Results:
1.701 + * A standard Tcl object result.
1.702 + *
1.703 + * Side effects:
1.704 + * Creates and frees objects.
1.705 + *
1.706 + *----------------------------------------------------------------------
1.707 + */
1.708 +
1.709 +static int
1.710 +TestobjCmd(clientData, interp, objc, objv)
1.711 + ClientData clientData; /* Not used. */
1.712 + Tcl_Interp *interp; /* Current interpreter. */
1.713 + int objc; /* Number of arguments. */
1.714 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.715 +{
1.716 + int varIndex, destIndex, i;
1.717 + char *index, *subCmd, *string;
1.718 + Tcl_ObjType *targetType;
1.719 +
1.720 + if (objc < 2) {
1.721 + wrongNumArgs:
1.722 + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1.723 + return TCL_ERROR;
1.724 + }
1.725 +
1.726 + subCmd = Tcl_GetString(objv[1]);
1.727 + if (strcmp(subCmd, "assign") == 0) {
1.728 + if (objc != 4) {
1.729 + goto wrongNumArgs;
1.730 + }
1.731 + index = Tcl_GetString(objv[2]);
1.732 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.733 + return TCL_ERROR;
1.734 + }
1.735 + if (CheckIfVarUnset(interp, varIndex)) {
1.736 + return TCL_ERROR;
1.737 + }
1.738 + string = Tcl_GetString(objv[3]);
1.739 + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
1.740 + return TCL_ERROR;
1.741 + }
1.742 + SetVarToObj(destIndex, varPtr[varIndex]);
1.743 + Tcl_SetObjResult(interp, varPtr[destIndex]);
1.744 + } else if (strcmp(subCmd, "convert") == 0) {
1.745 + char *typeName;
1.746 + if (objc != 4) {
1.747 + goto wrongNumArgs;
1.748 + }
1.749 + index = Tcl_GetString(objv[2]);
1.750 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.751 + return TCL_ERROR;
1.752 + }
1.753 + if (CheckIfVarUnset(interp, varIndex)) {
1.754 + return TCL_ERROR;
1.755 + }
1.756 + typeName = Tcl_GetString(objv[3]);
1.757 + if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
1.758 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.759 + "no type ", typeName, " found", (char *) NULL);
1.760 + return TCL_ERROR;
1.761 + }
1.762 + if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
1.763 + != TCL_OK) {
1.764 + return TCL_ERROR;
1.765 + }
1.766 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.767 + } else if (strcmp(subCmd, "duplicate") == 0) {
1.768 + if (objc != 4) {
1.769 + goto wrongNumArgs;
1.770 + }
1.771 + index = Tcl_GetString(objv[2]);
1.772 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.773 + return TCL_ERROR;
1.774 + }
1.775 + if (CheckIfVarUnset(interp, varIndex)) {
1.776 + return TCL_ERROR;
1.777 + }
1.778 + string = Tcl_GetString(objv[3]);
1.779 + if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
1.780 + return TCL_ERROR;
1.781 + }
1.782 + SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
1.783 + Tcl_SetObjResult(interp, varPtr[destIndex]);
1.784 + } else if (strcmp(subCmd, "freeallvars") == 0) {
1.785 + if (objc != 2) {
1.786 + goto wrongNumArgs;
1.787 + }
1.788 + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
1.789 + if (varPtr[i] != NULL) {
1.790 + Tcl_DecrRefCount(varPtr[i]);
1.791 + varPtr[i] = NULL;
1.792 + }
1.793 + }
1.794 + } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
1.795 + if ( objc != 3 ) {
1.796 + goto wrongNumArgs;
1.797 + }
1.798 + index = Tcl_GetString( objv[2] );
1.799 + if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
1.800 + return TCL_ERROR;
1.801 + }
1.802 + if (CheckIfVarUnset(interp, varIndex)) {
1.803 + return TCL_ERROR;
1.804 + }
1.805 + Tcl_InvalidateStringRep( varPtr[varIndex] );
1.806 + Tcl_SetObjResult( interp, varPtr[varIndex] );
1.807 + } else if (strcmp(subCmd, "newobj") == 0) {
1.808 + if (objc != 3) {
1.809 + goto wrongNumArgs;
1.810 + }
1.811 + index = Tcl_GetString(objv[2]);
1.812 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.813 + return TCL_ERROR;
1.814 + }
1.815 + SetVarToObj(varIndex, Tcl_NewObj());
1.816 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.817 + } else if (strcmp(subCmd, "objtype") == 0) {
1.818 + char *typeName;
1.819 +
1.820 + /*
1.821 + * return an object containing the name of the argument's type
1.822 + * of internal rep. If none exists, return "none".
1.823 + */
1.824 +
1.825 + if (objc != 3) {
1.826 + goto wrongNumArgs;
1.827 + }
1.828 + if (objv[2]->typePtr == NULL) {
1.829 + Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
1.830 + } else {
1.831 + typeName = objv[2]->typePtr->name;
1.832 + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
1.833 + }
1.834 + } else if (strcmp(subCmd, "refcount") == 0) {
1.835 + char buf[TCL_INTEGER_SPACE];
1.836 +
1.837 + if (objc != 3) {
1.838 + goto wrongNumArgs;
1.839 + }
1.840 + index = Tcl_GetString(objv[2]);
1.841 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.842 + return TCL_ERROR;
1.843 + }
1.844 + if (CheckIfVarUnset(interp, varIndex)) {
1.845 + return TCL_ERROR;
1.846 + }
1.847 + TclFormatInt(buf, varPtr[varIndex]->refCount);
1.848 + Tcl_SetResult(interp, buf, TCL_VOLATILE);
1.849 + } else if (strcmp(subCmd, "type") == 0) {
1.850 + if (objc != 3) {
1.851 + goto wrongNumArgs;
1.852 + }
1.853 + index = Tcl_GetString(objv[2]);
1.854 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.855 + return TCL_ERROR;
1.856 + }
1.857 + if (CheckIfVarUnset(interp, varIndex)) {
1.858 + return TCL_ERROR;
1.859 + }
1.860 + if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
1.861 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
1.862 + } else {
1.863 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.864 + varPtr[varIndex]->typePtr->name, -1);
1.865 + }
1.866 + } else if (strcmp(subCmd, "types") == 0) {
1.867 + if (objc != 2) {
1.868 + goto wrongNumArgs;
1.869 + }
1.870 + if (Tcl_AppendAllObjTypes(interp,
1.871 + Tcl_GetObjResult(interp)) != TCL_OK) {
1.872 + return TCL_ERROR;
1.873 + }
1.874 + } else {
1.875 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.876 + "bad option \"",
1.877 + Tcl_GetString(objv[1]),
1.878 + "\": must be assign, convert, duplicate, freeallvars, ",
1.879 + "newobj, objcount, objtype, refcount, type, or types",
1.880 + (char *) NULL);
1.881 + return TCL_ERROR;
1.882 + }
1.883 + return TCL_OK;
1.884 +}
1.885 +
1.886 +/*
1.887 + *----------------------------------------------------------------------
1.888 + *
1.889 + * TeststringobjCmd --
1.890 + *
1.891 + * This procedure implements the "teststringobj" command. It is used to
1.892 + * test the string Tcl object type implementation.
1.893 + *
1.894 + * Results:
1.895 + * A standard Tcl object result.
1.896 + *
1.897 + * Side effects:
1.898 + * Creates and frees string objects, and also converts objects to
1.899 + * have string type.
1.900 + *
1.901 + *----------------------------------------------------------------------
1.902 + */
1.903 +
1.904 +static int
1.905 +TeststringobjCmd(clientData, interp, objc, objv)
1.906 + ClientData clientData; /* Not used. */
1.907 + Tcl_Interp *interp; /* Current interpreter. */
1.908 + int objc; /* Number of arguments. */
1.909 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.910 +{
1.911 + int varIndex, option, i, length;
1.912 +#define MAX_STRINGS 11
1.913 + char *index, *string, *strings[MAX_STRINGS+1];
1.914 + TestString *strPtr;
1.915 + static CONST char *options[] = {
1.916 + "append", "appendstrings", "get", "get2", "length", "length2",
1.917 + "set", "set2", "setlength", "ualloc", "getunicode",
1.918 + (char *) NULL
1.919 + };
1.920 +
1.921 + if (objc < 3) {
1.922 + wrongNumArgs:
1.923 + Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1.924 + return TCL_ERROR;
1.925 + }
1.926 +
1.927 + index = Tcl_GetString(objv[2]);
1.928 + if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
1.929 + return TCL_ERROR;
1.930 + }
1.931 +
1.932 + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
1.933 + != TCL_OK) {
1.934 + return TCL_ERROR;
1.935 + }
1.936 + switch (option) {
1.937 + case 0: /* append */
1.938 + if (objc != 5) {
1.939 + goto wrongNumArgs;
1.940 + }
1.941 + if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
1.942 + return TCL_ERROR;
1.943 + }
1.944 + if (varPtr[varIndex] == NULL) {
1.945 + SetVarToObj(varIndex, Tcl_NewObj());
1.946 + }
1.947 +
1.948 + /*
1.949 + * If the object bound to variable "varIndex" is shared, we must
1.950 + * "copy on write" and append to a copy of the object.
1.951 + */
1.952 +
1.953 + if (Tcl_IsShared(varPtr[varIndex])) {
1.954 + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
1.955 + }
1.956 + string = Tcl_GetString(objv[3]);
1.957 + Tcl_AppendToObj(varPtr[varIndex], string, length);
1.958 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.959 + break;
1.960 + case 1: /* appendstrings */
1.961 + if (objc > (MAX_STRINGS+3)) {
1.962 + goto wrongNumArgs;
1.963 + }
1.964 + if (varPtr[varIndex] == NULL) {
1.965 + SetVarToObj(varIndex, Tcl_NewObj());
1.966 + }
1.967 +
1.968 + /*
1.969 + * If the object bound to variable "varIndex" is shared, we must
1.970 + * "copy on write" and append to a copy of the object.
1.971 + */
1.972 +
1.973 + if (Tcl_IsShared(varPtr[varIndex])) {
1.974 + SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
1.975 + }
1.976 + for (i = 3; i < objc; i++) {
1.977 + strings[i-3] = Tcl_GetString(objv[i]);
1.978 + }
1.979 + for ( ; i < 12 + 3; i++) {
1.980 + strings[i - 3] = NULL;
1.981 + }
1.982 + Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
1.983 + strings[2], strings[3], strings[4], strings[5],
1.984 + strings[6], strings[7], strings[8], strings[9],
1.985 + strings[10], strings[11]);
1.986 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.987 + break;
1.988 + case 2: /* get */
1.989 + if (objc != 3) {
1.990 + goto wrongNumArgs;
1.991 + }
1.992 + if (CheckIfVarUnset(interp, varIndex)) {
1.993 + return TCL_ERROR;
1.994 + }
1.995 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.996 + break;
1.997 + case 3: /* get2 */
1.998 + if (objc != 3) {
1.999 + goto wrongNumArgs;
1.1000 + }
1.1001 + if (CheckIfVarUnset(interp, varIndex)) {
1.1002 + return TCL_ERROR;
1.1003 + }
1.1004 + string = Tcl_GetString(varPtr[varIndex]);
1.1005 + Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
1.1006 + break;
1.1007 + case 4: /* length */
1.1008 + if (objc != 3) {
1.1009 + goto wrongNumArgs;
1.1010 + }
1.1011 + Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
1.1012 + ? varPtr[varIndex]->length : -1);
1.1013 + break;
1.1014 + case 5: /* length2 */
1.1015 + if (objc != 3) {
1.1016 + goto wrongNumArgs;
1.1017 + }
1.1018 + if (varPtr[varIndex] != NULL) {
1.1019 + strPtr = (TestString *)
1.1020 + (varPtr[varIndex])->internalRep.otherValuePtr;
1.1021 + length = (int) strPtr->allocated;
1.1022 + } else {
1.1023 + length = -1;
1.1024 + }
1.1025 + Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
1.1026 + break;
1.1027 + case 6: /* set */
1.1028 + if (objc != 4) {
1.1029 + goto wrongNumArgs;
1.1030 + }
1.1031 +
1.1032 + /*
1.1033 + * If the object currently bound to the variable with index
1.1034 + * varIndex has ref count 1 (i.e. the object is unshared) we
1.1035 + * can modify that object directly. Otherwise, if RC>1 (i.e.
1.1036 + * the object is shared), we must create a new object to
1.1037 + * modify/set and decrement the old formerly-shared object's
1.1038 + * ref count. This is "copy on write".
1.1039 + */
1.1040 +
1.1041 + string = Tcl_GetStringFromObj(objv[3], &length);
1.1042 + if ((varPtr[varIndex] != NULL)
1.1043 + && !Tcl_IsShared(varPtr[varIndex])) {
1.1044 + Tcl_SetStringObj(varPtr[varIndex], string, length);
1.1045 + } else {
1.1046 + SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
1.1047 + }
1.1048 + Tcl_SetObjResult(interp, varPtr[varIndex]);
1.1049 + break;
1.1050 + case 7: /* set2 */
1.1051 + if (objc != 4) {
1.1052 + goto wrongNumArgs;
1.1053 + }
1.1054 + SetVarToObj(varIndex, objv[3]);
1.1055 + break;
1.1056 + case 8: /* setlength */
1.1057 + if (objc != 4) {
1.1058 + goto wrongNumArgs;
1.1059 + }
1.1060 + if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
1.1061 + return TCL_ERROR;
1.1062 + }
1.1063 + if (varPtr[varIndex] != NULL) {
1.1064 + Tcl_SetObjLength(varPtr[varIndex], length);
1.1065 + }
1.1066 + break;
1.1067 + case 9: /* ualloc */
1.1068 + if (objc != 3) {
1.1069 + goto wrongNumArgs;
1.1070 + }
1.1071 + if (varPtr[varIndex] != NULL) {
1.1072 + strPtr = (TestString *)
1.1073 + (varPtr[varIndex])->internalRep.otherValuePtr;
1.1074 + length = (int) strPtr->uallocated;
1.1075 + } else {
1.1076 + length = -1;
1.1077 + }
1.1078 + Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
1.1079 + break;
1.1080 + case 10: /* getunicode */
1.1081 + if (objc != 3) {
1.1082 + goto wrongNumArgs;
1.1083 + }
1.1084 + Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
1.1085 + break;
1.1086 + }
1.1087 +
1.1088 + return TCL_OK;
1.1089 +}
1.1090 +
1.1091 +/*
1.1092 + *----------------------------------------------------------------------
1.1093 + *
1.1094 + * SetVarToObj --
1.1095 + *
1.1096 + * Utility routine to assign a Tcl_Obj* to a test variable. The
1.1097 + * Tcl_Obj* can be NULL.
1.1098 + *
1.1099 + * Results:
1.1100 + * None.
1.1101 + *
1.1102 + * Side effects:
1.1103 + * This routine handles ref counting details for assignment:
1.1104 + * i.e. the old value's ref count must be decremented (if not NULL) and
1.1105 + * the new one incremented (also if not NULL).
1.1106 + *
1.1107 + *----------------------------------------------------------------------
1.1108 + */
1.1109 +
1.1110 +static void
1.1111 +SetVarToObj(varIndex, objPtr)
1.1112 + int varIndex; /* Designates the assignment variable. */
1.1113 + Tcl_Obj *objPtr; /* Points to object to assign to var. */
1.1114 +{
1.1115 + if (varPtr[varIndex] != NULL) {
1.1116 + Tcl_DecrRefCount(varPtr[varIndex]);
1.1117 + }
1.1118 + varPtr[varIndex] = objPtr;
1.1119 + if (objPtr != NULL) {
1.1120 + Tcl_IncrRefCount(objPtr);
1.1121 + }
1.1122 +}
1.1123 +
1.1124 +/*
1.1125 + *----------------------------------------------------------------------
1.1126 + *
1.1127 + * GetVariableIndex --
1.1128 + *
1.1129 + * Utility routine to get a test variable index from the command line.
1.1130 + *
1.1131 + * Results:
1.1132 + * A standard Tcl object result.
1.1133 + *
1.1134 + * Side effects:
1.1135 + * None.
1.1136 + *
1.1137 + *----------------------------------------------------------------------
1.1138 + */
1.1139 +
1.1140 +static int
1.1141 +GetVariableIndex(interp, string, indexPtr)
1.1142 + Tcl_Interp *interp; /* Interpreter for error reporting. */
1.1143 + char *string; /* String containing a variable index
1.1144 + * specified as a nonnegative number less
1.1145 + * than NUMBER_OF_OBJECT_VARS. */
1.1146 + int *indexPtr; /* Place to store converted result. */
1.1147 +{
1.1148 + int index;
1.1149 +
1.1150 + if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
1.1151 + return TCL_ERROR;
1.1152 + }
1.1153 + if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
1.1154 + Tcl_ResetResult(interp);
1.1155 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
1.1156 + return TCL_ERROR;
1.1157 + }
1.1158 +
1.1159 + *indexPtr = index;
1.1160 + return TCL_OK;
1.1161 +}
1.1162 +
1.1163 +/*
1.1164 + *----------------------------------------------------------------------
1.1165 + *
1.1166 + * CheckIfVarUnset --
1.1167 + *
1.1168 + * Utility procedure that checks whether a test variable is readable:
1.1169 + * i.e., that varPtr[varIndex] is non-NULL.
1.1170 + *
1.1171 + * Results:
1.1172 + * 1 if the test variable is unset (NULL); 0 otherwise.
1.1173 + *
1.1174 + * Side effects:
1.1175 + * Sets the interpreter result to an error message if the variable is
1.1176 + * unset (NULL).
1.1177 + *
1.1178 + *----------------------------------------------------------------------
1.1179 + */
1.1180 +
1.1181 +static int
1.1182 +CheckIfVarUnset(interp, varIndex)
1.1183 + Tcl_Interp *interp; /* Interpreter for error reporting. */
1.1184 + int varIndex; /* Index of the test variable to check. */
1.1185 +{
1.1186 + if (varPtr[varIndex] == NULL) {
1.1187 + char buf[32 + TCL_INTEGER_SPACE];
1.1188 +
1.1189 + sprintf(buf, "variable %d is unset (NULL)", varIndex);
1.1190 + Tcl_ResetResult(interp);
1.1191 + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1.1192 + return 1;
1.1193 + }
1.1194 + return 0;
1.1195 +}