sl@0: /* 
sl@0:  * tclTestObj.c --
sl@0:  *
sl@0:  *	This file contains C command procedures for the additional Tcl
sl@0:  *	commands that are used for testing implementations of the Tcl object
sl@0:  *	types. These commands are not normally included in Tcl
sl@0:  *	applications; they're only used for testing.
sl@0:  *
sl@0:  * Copyright (c) 1995-1998 Sun Microsystems, Inc.
sl@0:  * Copyright (c) 1999 by Scriptics Corporation.
sl@0:  *
sl@0:  * See the file "license.terms" for information on usage and redistribution
sl@0:  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0:  *
sl@0:  * RCS: @(#) $Id: tclTestObj.c,v 1.12 2002/12/04 13:09:24 vincentdarley Exp $
sl@0:  */
sl@0: 
sl@0: #include "tclInt.h"
sl@0: 
sl@0: /*
sl@0:  * An array of Tcl_Obj pointers used in the commands that operate on or get
sl@0:  * the values of Tcl object-valued variables. varPtr[i] is the i-th
sl@0:  * variable's Tcl_Obj *.
sl@0:  */
sl@0: 
sl@0: #define NUMBER_OF_OBJECT_VARS 20
sl@0: static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
sl@0: 
sl@0: /*
sl@0:  * Forward declarations for procedures defined later in this file:
sl@0:  */
sl@0: 
sl@0: static int		CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 			    int varIndex));
sl@0: static int		GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
sl@0: 			    char *string, int *indexPtr));
sl@0: static void		SetVarToObj _ANSI_ARGS_((int varIndex,
sl@0: 			    Tcl_Obj *objPtr));
sl@0: int			TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
sl@0: static int		TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 			    Tcl_Interp *interp, int objc,
sl@0: 			    Tcl_Obj *CONST objv[]));
sl@0: static int		TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 			    Tcl_Interp *interp, int objc,
sl@0: 			    Tcl_Obj *CONST objv[]));
sl@0: static int		TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 			    Tcl_Interp *interp, int objc,
sl@0: 			    Tcl_Obj *CONST objv[]));
sl@0: static int		TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 			    Tcl_Interp *interp, int objc,
sl@0: 			    Tcl_Obj *CONST objv[]));
sl@0: static int		TestintobjCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 			    Tcl_Interp *interp, int objc,
sl@0: 			    Tcl_Obj *CONST objv[]));
sl@0: static int		TestobjCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 			    Tcl_Interp *interp, int objc,
sl@0: 			    Tcl_Obj *CONST objv[]));
sl@0: static int		TeststringobjCmd _ANSI_ARGS_((ClientData dummy,
sl@0: 			    Tcl_Interp *interp, int objc,
sl@0: 			    Tcl_Obj *CONST objv[]));
sl@0: 
sl@0: typedef struct TestString {
sl@0:     int numChars;
sl@0:     size_t allocated;
sl@0:     size_t uallocated;
sl@0:     Tcl_UniChar unicode[2];
sl@0: } TestString;
sl@0: 
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TclObjTest_Init --
sl@0:  *
sl@0:  *	This procedure creates additional commands that are used to test the
sl@0:  *	Tcl object support.
sl@0:  *
sl@0:  * Results:
sl@0:  *	Returns a standard Tcl completion code, and leaves an error
sl@0:  *	message in the interp's result if an error occurs.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Creates and registers several new testing commands.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: int
sl@0: TclObjTest_Init(interp)
sl@0:     Tcl_Interp *interp;
sl@0: {
sl@0:     register int i;
sl@0:     
sl@0:     for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
sl@0:         varPtr[i] = NULL;
sl@0:     }
sl@0: 	
sl@0:     Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
sl@0: 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
sl@0: 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
sl@0: 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
sl@0: 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
sl@0: 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
sl@0: 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
sl@0: 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestbooleanobjCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testbooleanobj" command.  It is used
sl@0:  *	to test the boolean Tcl object type implementation.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Creates and frees boolean objects, and also converts objects to
sl@0:  *	have boolean type.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestbooleanobjCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;	/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     int varIndex, boolValue;
sl@0:     char *index, *subCmd;
sl@0: 
sl@0:     if (objc < 3) {
sl@0: 	wrongNumArgs:
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     index = Tcl_GetString(objv[2]);
sl@0:     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     subCmd = Tcl_GetString(objv[1]);
sl@0:     if (strcmp(subCmd, "set") == 0) {
sl@0: 	if (objc != 4) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 
sl@0: 	/*
sl@0: 	 * If the object currently bound to the variable with index varIndex
sl@0: 	 * has ref count 1 (i.e. the object is unshared) we can modify that
sl@0: 	 * object directly. Otherwise, if RC>1 (i.e. the object is shared),
sl@0: 	 * we must create a new object to modify/set and decrement the old
sl@0: 	 * formerly-shared object's ref count. This is "copy on write".
sl@0: 	 */
sl@0: 
sl@0: 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "get") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "not") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
sl@0: 				  &boolValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (!Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else {
sl@0: 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"bad option \"", Tcl_GetString(objv[1]),
sl@0: 		"\": must be set, get, or not", (char *) NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestconvertobjCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testconvertobj" command. It is used
sl@0:  *	to test converting objects to new types.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Converts objects to new types.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestconvertobjCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;	/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     char *subCmd;
sl@0:     char buf[20];
sl@0: 
sl@0:     if (objc < 3) {
sl@0: 	wrongNumArgs:
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     subCmd = Tcl_GetString(objv[1]);
sl@0:     if (strcmp(subCmd, "double") == 0) {
sl@0: 	double d;
sl@0: 
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	sprintf(buf, "%f", d);
sl@0:         Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
sl@0:     } else {
sl@0: 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"bad option \"", Tcl_GetString(objv[1]),
sl@0: 		"\": must be double", (char *) NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestdoubleobjCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testdoubleobj" command.  It is used
sl@0:  *	to test the double-precision floating point Tcl object type
sl@0:  *	implementation.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Creates and frees double objects, and also converts objects to
sl@0:  *	have double type.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestdoubleobjCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;	/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     int varIndex;
sl@0:     double doubleValue;
sl@0:     char *index, *subCmd, *string;
sl@0: 	
sl@0:     if (objc < 3) {
sl@0: 	wrongNumArgs:
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     index = Tcl_GetString(objv[2]);
sl@0:     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     subCmd = Tcl_GetString(objv[1]);
sl@0:     if (strcmp(subCmd, "set") == 0) {
sl@0: 	if (objc != 4) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	string = Tcl_GetString(objv[3]);
sl@0: 	if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 
sl@0: 	/*
sl@0: 	 * If the object currently bound to the variable with index varIndex
sl@0: 	 * has ref count 1 (i.e. the object is unshared) we can modify that
sl@0: 	 * object directly. Otherwise, if RC>1 (i.e. the object is shared),
sl@0: 	 * we must create a new object to modify/set and decrement the old
sl@0: 	 * formerly-shared object's ref count. This is "copy on write".
sl@0: 	 */
sl@0: 
sl@0: 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "get") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "mult10") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
sl@0: 				 &doubleValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (!Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "div10") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
sl@0: 				 &doubleValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (!Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else {
sl@0: 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"bad option \"", Tcl_GetString(objv[1]),
sl@0: 		"\": must be set, get, mult10, or div10", (char *) NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestindexobjCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testindexobj" command. It is used to
sl@0:  *	test the index Tcl object type implementation.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Creates and frees int objects, and also converts objects to
sl@0:  *	have int type.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestindexobjCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;	/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     int allowAbbrev, index, index2, setError, i, result;
sl@0:     CONST char **argv;
sl@0:     static CONST char *tablePtr[] = {"a", "b", "check", (char *) NULL};
sl@0:     /*
sl@0:      * Keep this structure declaration in sync with tclIndexObj.c
sl@0:      */
sl@0:     struct IndexRep {
sl@0: 	VOID *tablePtr;			/* Pointer to the table of strings */
sl@0: 	int offset;			/* Offset between table entries */
sl@0: 	int index;			/* Selected index into table. */
sl@0:     };
sl@0:     struct IndexRep *indexRep;
sl@0: 
sl@0:     if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
sl@0: 	    "check") == 0)) {
sl@0: 	/*
sl@0: 	 * This code checks to be sure that the results of
sl@0: 	 * Tcl_GetIndexFromObj are properly cached in the object and
sl@0: 	 * returned on subsequent lookups.
sl@0: 	 */
sl@0: 
sl@0: 	if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 
sl@0: 	Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
sl@0: 		"token", 0, &index);
sl@0: 	indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
sl@0: 	indexRep->index = index2;
sl@0: 	result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
sl@0: 		tablePtr, "token", 0, &index);
sl@0: 	if (result == TCL_OK) {
sl@0: 	    Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
sl@0: 	}
sl@0: 	return result;
sl@0:     }
sl@0: 
sl@0:     if (objc < 5) {
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     argv = (CONST char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
sl@0:     for (i = 4; i < objc; i++) {
sl@0: 	argv[i-4] = Tcl_GetString(objv[i]);
sl@0:     }
sl@0:     argv[objc-4] = NULL;
sl@0:     
sl@0:     /*
sl@0:      * Tcl_GetIndexFromObj assumes that the table is statically-allocated
sl@0:      * so that its address is different for each index object. If we
sl@0:      * accidently allocate a table at the same address as that cached in
sl@0:      * the index object, clear out the object's cached state.
sl@0:      */
sl@0: 
sl@0:     if ( objv[3]->typePtr != NULL
sl@0: 	 && !strcmp( "index", objv[3]->typePtr->name ) ) {
sl@0: 	indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
sl@0: 	if (indexRep->tablePtr == (VOID *) argv) {
sl@0: 	    objv[3]->typePtr->freeIntRepProc(objv[3]);
sl@0: 	    objv[3]->typePtr = NULL;
sl@0: 	}
sl@0:     }
sl@0: 
sl@0:     result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
sl@0: 	    argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
sl@0:     ckfree((char *) argv);
sl@0:     if (result == TCL_OK) {
sl@0: 	Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
sl@0:     }
sl@0:     return result;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestintobjCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testintobj" command. It is used to
sl@0:  *	test the int Tcl object type implementation.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Creates and frees int objects, and also converts objects to
sl@0:  *	have int type.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestintobjCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;	/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     int intValue, varIndex, i;
sl@0:     long longValue;
sl@0:     char *index, *subCmd, *string;
sl@0: 	
sl@0:     if (objc < 3) {
sl@0: 	wrongNumArgs:
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     index = Tcl_GetString(objv[2]);
sl@0:     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     subCmd = Tcl_GetString(objv[1]);
sl@0:     if (strcmp(subCmd, "set") == 0) {
sl@0: 	if (objc != 4) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	string = Tcl_GetString(objv[3]);
sl@0: 	if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	intValue = i;
sl@0: 
sl@0: 	/*
sl@0: 	 * If the object currently bound to the variable with index varIndex
sl@0: 	 * has ref count 1 (i.e. the object is unshared) we can modify that
sl@0: 	 * object directly. Otherwise, if RC>1 (i.e. the object is shared),
sl@0: 	 * we must create a new object to modify/set and decrement the old
sl@0: 	 * formerly-shared object's ref count. This is "copy on write".
sl@0: 	 */
sl@0: 
sl@0: 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetIntObj(varPtr[varIndex], intValue);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
sl@0: 	if (objc != 4) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	string = Tcl_GetString(objv[3]);
sl@0: 	if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	intValue = i;
sl@0: 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetIntObj(varPtr[varIndex], intValue);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
sl@0: 	}
sl@0:     } else if (strcmp(subCmd, "setlong") == 0) {
sl@0: 	if (objc != 4) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	string = Tcl_GetString(objv[3]);
sl@0: 	if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	intValue = i;
sl@0: 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetLongObj(varPtr[varIndex], intValue);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "setmaxlong") == 0) {
sl@0: 	long maxLong = LONG_MAX;
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetLongObj(varPtr[varIndex], maxLong);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
sl@0: 	}
sl@0:     } else if (strcmp(subCmd, "ismaxlong") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0: 	        ((longValue == LONG_MAX)? "1" : "0"), -1);
sl@0:     } else if (strcmp(subCmd, "get") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "get2") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	string = Tcl_GetString(varPtr[varIndex]);
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
sl@0:     } else if (strcmp(subCmd, "inttoobigtest") == 0) {
sl@0: 	/*
sl@0: 	 * If long ints have more bits than ints on this platform, verify
sl@0: 	 * that Tcl_GetIntFromObj returns an error if the long int held
sl@0: 	 * in an integer object's internal representation is too large
sl@0: 	 * to fit in an int.
sl@0: 	 */
sl@0: 	
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: #if (INT_MAX == LONG_MAX)   /* int is same size as long int */
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
sl@0: #else 
sl@0: 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
sl@0: 	}
sl@0: 	if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
sl@0: 	    Tcl_ResetResult(interp);
sl@0: 	    Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
sl@0: 	    return TCL_OK;
sl@0: 	}
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
sl@0: #endif
sl@0:     } else if (strcmp(subCmd, "mult10") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
sl@0: 			      &intValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (!Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "div10") == 0) {
sl@0: 	if (objc != 3) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
sl@0: 			      &intValue) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	if (!Tcl_IsShared(varPtr[varIndex])) {
sl@0: 	    Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
sl@0: 	} else {
sl@0: 	    SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
sl@0: 	}
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else {
sl@0: 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"bad option \"", Tcl_GetString(objv[1]),
sl@0: 		"\": must be set, get, get2, mult10, or div10",
sl@0: 		(char *) NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TestobjCmd --
sl@0:  *
sl@0:  *	This procedure implements the "testobj" command. It is used to test
sl@0:  *	the type-independent portions of the Tcl object type implementation.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Creates and frees objects.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TestobjCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;	/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     int varIndex, destIndex, i;
sl@0:     char *index, *subCmd, *string;
sl@0:     Tcl_ObjType *targetType;
sl@0: 	
sl@0:     if (objc < 2) {
sl@0: 	wrongNumArgs:
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     subCmd = Tcl_GetString(objv[1]);
sl@0:     if (strcmp(subCmd, "assign") == 0) {
sl@0:         if (objc != 4) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0:         index = Tcl_GetString(objv[2]);
sl@0:         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	string = Tcl_GetString(objv[3]);
sl@0:         if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         SetVarToObj(destIndex, varPtr[varIndex]);
sl@0: 	Tcl_SetObjResult(interp, varPtr[destIndex]);
sl@0:      } else if (strcmp(subCmd, "convert") == 0) {
sl@0:         char *typeName;
sl@0:         if (objc != 4) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0:         index = Tcl_GetString(objv[2]);
sl@0:         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0:         typeName = Tcl_GetString(objv[3]);
sl@0:         if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
sl@0: 	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		    "no type ", typeName, " found", (char *) NULL);
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
sl@0:             != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "duplicate") == 0) {
sl@0:         if (objc != 4) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0:         index = Tcl_GetString(objv[2]);
sl@0:         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	string = Tcl_GetString(objv[3]);
sl@0:         if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
sl@0: 	Tcl_SetObjResult(interp, varPtr[destIndex]);
sl@0:     } else if (strcmp(subCmd, "freeallvars") == 0) {
sl@0:         if (objc != 2) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0:         for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
sl@0:             if (varPtr[i] != NULL) {
sl@0:                 Tcl_DecrRefCount(varPtr[i]);
sl@0:                 varPtr[i] = NULL;
sl@0:             }
sl@0:         }
sl@0:     } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
sl@0: 	if ( objc != 3 ) {
sl@0: 	    goto wrongNumArgs;
sl@0: 	}
sl@0: 	index = Tcl_GetString( objv[2] );
sl@0: 	if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0:         if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	Tcl_InvalidateStringRep( varPtr[varIndex] );
sl@0: 	Tcl_SetObjResult( interp, varPtr[varIndex] );
sl@0:     } else if (strcmp(subCmd, "newobj") == 0) {
sl@0:         if (objc != 3) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0:         index = Tcl_GetString(objv[2]);
sl@0:         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         SetVarToObj(varIndex, Tcl_NewObj());
sl@0: 	Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0:     } else if (strcmp(subCmd, "objtype") == 0) {
sl@0: 	char *typeName;
sl@0: 
sl@0: 	/*
sl@0: 	 * return an object containing the name of the argument's type
sl@0: 	 * of internal rep.  If none exists, return "none".
sl@0: 	 */
sl@0: 	
sl@0:         if (objc != 3) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0: 	if (objv[2]->typePtr == NULL) {
sl@0: 	    Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
sl@0: 	} else {
sl@0: 	    typeName = objv[2]->typePtr->name;
sl@0: 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
sl@0: 	}
sl@0:     } else if (strcmp(subCmd, "refcount") == 0) {
sl@0: 	char buf[TCL_INTEGER_SPACE];
sl@0: 
sl@0:         if (objc != 3) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0:         index = Tcl_GetString(objv[2]);
sl@0:         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0: 	TclFormatInt(buf, varPtr[varIndex]->refCount);
sl@0:         Tcl_SetResult(interp, buf, TCL_VOLATILE);
sl@0:     } else if (strcmp(subCmd, "type") == 0) {
sl@0:         if (objc != 3) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0:         index = Tcl_GetString(objv[2]);
sl@0:         if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0:             return TCL_ERROR;
sl@0:         }
sl@0:         if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0:         if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
sl@0: 	    Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
sl@0:         } else {
sl@0:             Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0:                     varPtr[varIndex]->typePtr->name, -1);
sl@0:         }
sl@0:     } else if (strcmp(subCmd, "types") == 0) {
sl@0:         if (objc != 2) {
sl@0:             goto wrongNumArgs;
sl@0:         }
sl@0: 	if (Tcl_AppendAllObjTypes(interp,
sl@0: 		Tcl_GetObjResult(interp)) != TCL_OK) {
sl@0: 	    return TCL_ERROR;
sl@0: 	}
sl@0:     } else {
sl@0: 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0: 		"bad option \"",
sl@0: 		Tcl_GetString(objv[1]),
sl@0: 		"\": must be assign, convert, duplicate, freeallvars, ",
sl@0: 		"newobj, objcount, objtype, refcount, type, or types",
sl@0: 		(char *) NULL);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * TeststringobjCmd --
sl@0:  *
sl@0:  *	This procedure implements the "teststringobj" command. It is used to
sl@0:  *	test the string Tcl object type implementation.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Creates and frees string objects, and also converts objects to
sl@0:  *	have string type.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: TeststringobjCmd(clientData, interp, objc, objv)
sl@0:     ClientData clientData;	/* Not used. */
sl@0:     Tcl_Interp *interp;		/* Current interpreter. */
sl@0:     int objc;			/* Number of arguments. */
sl@0:     Tcl_Obj *CONST objv[];	/* Argument objects. */
sl@0: {
sl@0:     int varIndex, option, i, length;
sl@0: #define MAX_STRINGS 11
sl@0:     char *index, *string, *strings[MAX_STRINGS+1];
sl@0:     TestString *strPtr;
sl@0:     static CONST char *options[] = {
sl@0: 	"append", "appendstrings", "get", "get2", "length", "length2",
sl@0: 	"set", "set2", "setlength", "ualloc", "getunicode", 
sl@0: 	(char *) NULL
sl@0:     };
sl@0: 
sl@0:     if (objc < 3) {
sl@0: 	wrongNumArgs:
sl@0: 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     index = Tcl_GetString(objv[2]);
sl@0:     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
sl@0: 	    != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     switch (option) {
sl@0: 	case 0:				/* append */
sl@0: 	    if (objc != 5) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    if (varPtr[varIndex] == NULL) {
sl@0: 		SetVarToObj(varIndex, Tcl_NewObj());
sl@0: 	    }
sl@0: 	    
sl@0: 	    /*
sl@0: 	     * If the object bound to variable "varIndex" is shared, we must
sl@0: 	     * "copy on write" and append to a copy of the object. 
sl@0: 	     */
sl@0: 	    
sl@0: 	    if (Tcl_IsShared(varPtr[varIndex])) {
sl@0: 		SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
sl@0: 	    }
sl@0: 	    string = Tcl_GetString(objv[3]);
sl@0: 	    Tcl_AppendToObj(varPtr[varIndex], string, length);
sl@0: 	    Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0: 	    break;
sl@0: 	case 1:				/* appendstrings */
sl@0: 	    if (objc > (MAX_STRINGS+3)) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    if (varPtr[varIndex] == NULL) {
sl@0: 		SetVarToObj(varIndex, Tcl_NewObj());
sl@0: 	    }
sl@0: 
sl@0: 	    /*
sl@0: 	     * If the object bound to variable "varIndex" is shared, we must
sl@0: 	     * "copy on write" and append to a copy of the object. 
sl@0: 	     */
sl@0: 
sl@0: 	    if (Tcl_IsShared(varPtr[varIndex])) {
sl@0: 		SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
sl@0: 	    }
sl@0: 	    for (i = 3;  i < objc;  i++) {
sl@0: 		strings[i-3] = Tcl_GetString(objv[i]);
sl@0: 	    }
sl@0: 	    for ( ; i < 12 + 3; i++) {
sl@0: 		strings[i - 3] = NULL;
sl@0: 	    }
sl@0: 	    Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
sl@0: 		    strings[2], strings[3], strings[4], strings[5],
sl@0: 		    strings[6], strings[7], strings[8], strings[9],
sl@0: 		    strings[10], strings[11]);
sl@0: 	    Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0: 	    break;
sl@0: 	case 2:				/* get */
sl@0: 	    if (objc != 3) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0: 	    break;
sl@0: 	case 3:				/* get2 */
sl@0: 	    if (objc != 3) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    if (CheckIfVarUnset(interp, varIndex)) {
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    string = Tcl_GetString(varPtr[varIndex]);
sl@0: 	    Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
sl@0: 	    break;
sl@0: 	case 4:				/* length */
sl@0: 	    if (objc != 3) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
sl@0: 		    ? varPtr[varIndex]->length : -1);
sl@0: 	    break;
sl@0: 	case 5:				/* length2 */
sl@0: 	    if (objc != 3) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    if (varPtr[varIndex] != NULL) {
sl@0: 		strPtr = (TestString *)
sl@0: 		    (varPtr[varIndex])->internalRep.otherValuePtr;
sl@0: 		length = (int) strPtr->allocated;
sl@0: 	    } else {
sl@0: 		length = -1;
sl@0: 	    }
sl@0: 	    Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
sl@0: 	    break;
sl@0: 	case 6:				/* set */
sl@0: 	    if (objc != 4) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 
sl@0: 	    /*
sl@0: 	     * If the object currently bound to the variable with index
sl@0: 	     * varIndex has ref count 1 (i.e. the object is unshared) we
sl@0: 	     * can modify that object directly. Otherwise, if RC>1 (i.e.
sl@0: 	     * the object is shared), we must create a new object to
sl@0: 	     * modify/set and decrement the old formerly-shared object's
sl@0: 	     * ref count. This is "copy on write".
sl@0: 	     */
sl@0:     
sl@0: 	    string = Tcl_GetStringFromObj(objv[3], &length);
sl@0: 	    if ((varPtr[varIndex] != NULL)
sl@0: 		    && !Tcl_IsShared(varPtr[varIndex])) {
sl@0: 		Tcl_SetStringObj(varPtr[varIndex], string, length);
sl@0: 	    } else {
sl@0: 		SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
sl@0: 	    }
sl@0: 	    Tcl_SetObjResult(interp, varPtr[varIndex]);
sl@0: 	    break;
sl@0: 	case 7:				/* set2 */
sl@0: 	    if (objc != 4) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    SetVarToObj(varIndex, objv[3]);
sl@0: 	    break;
sl@0: 	case 8:				/* setlength */
sl@0: 	    if (objc != 4) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
sl@0: 		return TCL_ERROR;
sl@0: 	    }
sl@0: 	    if (varPtr[varIndex] != NULL) {
sl@0: 		Tcl_SetObjLength(varPtr[varIndex], length);
sl@0: 	    }
sl@0: 	    break;
sl@0: 	case 9:				/* ualloc */
sl@0: 	    if (objc != 3) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    if (varPtr[varIndex] != NULL) {
sl@0: 		strPtr = (TestString *)
sl@0: 		    (varPtr[varIndex])->internalRep.otherValuePtr;
sl@0: 		length = (int) strPtr->uallocated;
sl@0: 	    } else {
sl@0: 		length = -1;
sl@0: 	    }
sl@0: 	    Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
sl@0: 	    break;
sl@0: 	case 10:			/* getunicode */
sl@0: 	    if (objc != 3) {
sl@0: 		goto wrongNumArgs;
sl@0: 	    }
sl@0: 	    Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
sl@0: 	    break;
sl@0:     }
sl@0: 
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * SetVarToObj --
sl@0:  *
sl@0:  *	Utility routine to assign a Tcl_Obj* to a test variable. The
sl@0:  *	Tcl_Obj* can be NULL.
sl@0:  *
sl@0:  * Results:
sl@0:  *	None.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	This routine handles ref counting details for assignment:
sl@0:  *	i.e. the old value's ref count must be decremented (if not NULL) and
sl@0:  *	the new one incremented (also if not NULL).
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static void
sl@0: SetVarToObj(varIndex, objPtr)
sl@0:     int varIndex;		/* Designates the assignment variable. */
sl@0:     Tcl_Obj *objPtr;		/* Points to object to assign to var. */
sl@0: {
sl@0:     if (varPtr[varIndex] != NULL) {
sl@0: 	Tcl_DecrRefCount(varPtr[varIndex]);
sl@0:     }
sl@0:     varPtr[varIndex] = objPtr;
sl@0:     if (objPtr != NULL) {
sl@0: 	Tcl_IncrRefCount(objPtr);
sl@0:     }
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * GetVariableIndex --
sl@0:  *
sl@0:  *	Utility routine to get a test variable index from the command line.
sl@0:  *
sl@0:  * Results:
sl@0:  *	A standard Tcl object result.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	None.
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: GetVariableIndex(interp, string, indexPtr)
sl@0:     Tcl_Interp *interp;         /* Interpreter for error reporting. */
sl@0:     char *string;               /* String containing a variable index
sl@0: 				 * specified as a nonnegative number less
sl@0: 				 * than NUMBER_OF_OBJECT_VARS. */
sl@0:     int *indexPtr;              /* Place to store converted result. */
sl@0: {
sl@0:     int index;
sl@0:     
sl@0:     if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0:     if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
sl@0: 	Tcl_ResetResult(interp);
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
sl@0: 	return TCL_ERROR;
sl@0:     }
sl@0: 
sl@0:     *indexPtr = index;
sl@0:     return TCL_OK;
sl@0: }
sl@0: 
sl@0: /*
sl@0:  *----------------------------------------------------------------------
sl@0:  *
sl@0:  * CheckIfVarUnset --
sl@0:  *
sl@0:  *	Utility procedure that checks whether a test variable is readable:
sl@0:  *	i.e., that varPtr[varIndex] is non-NULL.
sl@0:  *
sl@0:  * Results:
sl@0:  *	1 if the test variable is unset (NULL); 0 otherwise.
sl@0:  *
sl@0:  * Side effects:
sl@0:  *	Sets the interpreter result to an error message if the variable is
sl@0:  *	unset (NULL).
sl@0:  *
sl@0:  *----------------------------------------------------------------------
sl@0:  */
sl@0: 
sl@0: static int
sl@0: CheckIfVarUnset(interp, varIndex)
sl@0:     Tcl_Interp *interp;		/* Interpreter for error reporting. */
sl@0:     int varIndex;		/* Index of the test variable to check. */
sl@0: {
sl@0:     if (varPtr[varIndex] == NULL) {
sl@0: 	char buf[32 + TCL_INTEGER_SPACE];
sl@0: 	
sl@0: 	sprintf(buf, "variable %d is unset (NULL)", varIndex);
sl@0: 	Tcl_ResetResult(interp);
sl@0: 	Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
sl@0: 	return 1;
sl@0:     }
sl@0:     return 0;
sl@0: }