/* 

 * tclTestObj.c --

 *

 *	This file contains C command procedures for the additional Tcl

 *	commands that are used for testing implementations of the Tcl object

 *	types. These commands are not normally included in Tcl

 *	applications; they're only used for testing.

 *

 * Copyright (c) 1995-1998 Sun Microsystems, Inc.

 * Copyright (c) 1999 by Scriptics Corporation.

 *

 * See the file "license.terms" for information on usage and redistribution

 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 *

 * RCS: @(#) $Id: tclTestObj.c,v 1.12 2002/12/04 13:09:24 vincentdarley Exp $

 */

#include "tclInt.h"

/*

 * An array of Tcl_Obj pointers used in the commands that operate on or get

 * the values of Tcl object-valued variables. varPtr[i] is the i-th

 * variable's Tcl_Obj *.

 */

#define NUMBER_OF_OBJECT_VARS 20

static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];

/*

 * Forward declarations for procedures defined later in this file:

 */

static int		CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,

			    int varIndex));

static int		GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,

			    char *string, int *indexPtr));

static void		SetVarToObj _ANSI_ARGS_((int varIndex,

			    Tcl_Obj *objPtr));

int			TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));

static int		TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,

			    Tcl_Interp *interp, int objc,

			    Tcl_Obj *CONST objv[]));

static int		TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,

			    Tcl_Interp *interp, int objc,

			    Tcl_Obj *CONST objv[]));

static int		TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,

			    Tcl_Interp *interp, int objc,

			    Tcl_Obj *CONST objv[]));

static int		TestindexobjCmd _ANSI_ARGS_((ClientData dummy,

			    Tcl_Interp *interp, int objc,

			    Tcl_Obj *CONST objv[]));

static int		TestintobjCmd _ANSI_ARGS_((ClientData dummy,

			    Tcl_Interp *interp, int objc,

			    Tcl_Obj *CONST objv[]));

static int		TestobjCmd _ANSI_ARGS_((ClientData dummy,

			    Tcl_Interp *interp, int objc,

			    Tcl_Obj *CONST objv[]));

static int		TeststringobjCmd _ANSI_ARGS_((ClientData dummy,

			    Tcl_Interp *interp, int objc,

			    Tcl_Obj *CONST objv[]));

typedef struct TestString {

    int numChars;

    size_t allocated;

    size_t uallocated;

    Tcl_UniChar unicode[2];

} TestString;

/*

 *----------------------------------------------------------------------

 *

 * TclObjTest_Init --

 *

 *	This procedure creates additional commands that are used to test the

 *	Tcl object support.

 *

 * Results:

 *	Returns a standard Tcl completion code, and leaves an error

 *	message in the interp's result if an error occurs.

 *

 * Side effects:

 *	Creates and registers several new testing commands.

 *

 *----------------------------------------------------------------------

 */

int

TclObjTest_Init(interp)

    Tcl_Interp *interp;

{

    register int i;

    for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {

        varPtr[i] = NULL;

    }

    Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,

	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * TestbooleanobjCmd --

 *

 *	This procedure implements the "testbooleanobj" command.  It is used

 *	to test the boolean Tcl object type implementation.

 *

 * Results:

 *	A standard Tcl object result.

 *

 * Side effects:

 *	Creates and frees boolean objects, and also converts objects to

 *	have boolean type.

 *

 *----------------------------------------------------------------------

 */

static int

TestbooleanobjCmd(clientData, interp, objc, objv)

    ClientData clientData;	/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    int varIndex, boolValue;

    char *index, *subCmd;

    if (objc < 3) {

	wrongNumArgs:

	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");

	return TCL_ERROR;

    }

    index = Tcl_GetString(objv[2]);

    if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {

	return TCL_ERROR;

    }

    subCmd = Tcl_GetString(objv[1]);

    if (strcmp(subCmd, "set") == 0) {

	if (objc != 4) {

	    goto wrongNumArgs;

	}

	if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {

	    return TCL_ERROR;

	}

	/*

	 * If the object currently bound to the variable with index varIndex

	 * has ref count 1 (i.e. the object is unshared) we can modify that

	 * object directly. Otherwise, if RC>1 (i.e. the object is shared),

	 * we must create a new object to modify/set and decrement the old

	 * formerly-shared object's ref count. This is "copy on write".

	 */

	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {

	    Tcl_SetBooleanObj(varPtr[varIndex], boolValue);

	} else {

	    SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));

	}

	Tcl_SetObjResult(interp, varPtr[varIndex]);

    } else if (strcmp(subCmd, "get") == 0) {

	if (objc != 3) {

	    goto wrongNumArgs;

	}

	if (CheckIfVarUnset(interp, varIndex)) {

	    return TCL_ERROR;

	}

	Tcl_SetObjResult(interp, varPtr[varIndex]);

    } else if (strcmp(subCmd, "not") == 0) {

	if (objc != 3) {

	    goto wrongNumArgs;

	}

	if (CheckIfVarUnset(interp, varIndex)) {

	    return TCL_ERROR;

	}

	if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],

				  &boolValue) != TCL_OK) {

	    return TCL_ERROR;

	}

	if (!Tcl_IsShared(varPtr[varIndex])) {

	    Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);

	} else {

	    SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));

	}

	Tcl_SetObjResult(interp, varPtr[varIndex]);

    } else {

	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

		"bad option \"", Tcl_GetString(objv[1]),

		"\": must be set, get, or not", (char *) NULL);

	return TCL_ERROR;

    }

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * TestconvertobjCmd --

 *

 *	This procedure implements the "testconvertobj" command. It is used

 *	to test converting objects to new types.

 *

 * Results:

 *	A standard Tcl object result.

 *

 * Side effects:

 *	Converts objects to new types.

 *

 *----------------------------------------------------------------------

 */

static int

TestconvertobjCmd(clientData, interp, objc, objv)

    ClientData clientData;	/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    char *subCmd;

    char buf[20];

    if (objc < 3) {

	wrongNumArgs:

	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");

	return TCL_ERROR;

    }

    subCmd = Tcl_GetString(objv[1]);

    if (strcmp(subCmd, "double") == 0) {

	double d;

	if (objc != 3) {

	    goto wrongNumArgs;

	}

	if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {

	    return TCL_ERROR;

	}

	sprintf(buf, "%f", d);

        Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);

    } else {

	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

		"bad option \"", Tcl_GetString(objv[1]),

		"\": must be double", (char *) NULL);

	return TCL_ERROR;

    }

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * TestdoubleobjCmd --

 *

 *	This procedure implements the "testdoubleobj" command.  It is used

 *	to test the double-precision floating point Tcl object type

 *	implementation.

 *

 * Results:

 *	A standard Tcl object result.

 *

 * Side effects:

 *	Creates and frees double objects, and also converts objects to

 *	have double type.

 *

 *----------------------------------------------------------------------

 */

static int

TestdoubleobjCmd(clientData, interp, objc, objv)

    ClientData clientData;	/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    int varIndex;

    double doubleValue;

    char *index, *subCmd, *string;

    if (objc < 3) {

	wrongNumArgs:

	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");

	return TCL_ERROR;

    }

    index = Tcl_GetString(objv[2]);

    if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {

	return TCL_ERROR;

    }

    subCmd = Tcl_GetString(objv[1]);

    if (strcmp(subCmd, "set") == 0) {

	if (objc != 4) {

	    goto wrongNumArgs;

	}

	string = Tcl_GetString(objv[3]);

	if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {

	    return TCL_ERROR;

	}

	/*

	 * If the object currently bound to the variable with index varIndex

	 * has ref count 1 (i.e. the object is unshared) we can modify that

	 * object directly. Otherwise, if RC>1 (i.e. the object is shared),

	 * we must create a new object to modify/set and decrement the old

	 * formerly-shared object's ref count. This is "copy on write".

	 */

	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {

	    Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);

	} else {

	    SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));

	}

	Tcl_SetObjResult(interp, varPtr[varIndex]);

    } else if (strcmp(subCmd, "get") == 0) {

	if (objc != 3) {

	    goto wrongNumArgs;

	}

	if (CheckIfVarUnset(interp, varIndex)) {

	    return TCL_ERROR;

	}

	Tcl_SetObjResult(interp, varPtr[varIndex]);

    } else if (strcmp(subCmd, "mult10") == 0) {

	if (objc != 3) {

	    goto wrongNumArgs;

	}

	if (CheckIfVarUnset(interp, varIndex)) {

	    return TCL_ERROR;

	}

	if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],

				 &doubleValue) != TCL_OK) {

	    return TCL_ERROR;

	}

	if (!Tcl_IsShared(varPtr[varIndex])) {

	    Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));

	} else {

	    SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));

	}

	Tcl_SetObjResult(interp, varPtr[varIndex]);

    } else if (strcmp(subCmd, "div10") == 0) {

	if (objc != 3) {

	    goto wrongNumArgs;

	}

	if (CheckIfVarUnset(interp, varIndex)) {

	    return TCL_ERROR;

	}

	if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],

				 &doubleValue) != TCL_OK) {

	    return TCL_ERROR;

	}

	if (!Tcl_IsShared(varPtr[varIndex])) {

	    Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));

	} else {

	    SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));

	}

	Tcl_SetObjResult(interp, varPtr[varIndex]);

    } else {

	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),

		"bad option \"", Tcl_GetString(objv[1]),

		"\": must be set, get, mult10, or div10", (char *) NULL);

	return TCL_ERROR;

    }

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * TestindexobjCmd --

 *

 *	This procedure implements the "testindexobj" command. It is used to

 *	test the index Tcl object type implementation.

 *

 * Results:

 *	A standard Tcl object result.

 *

 * Side effects:

 *	Creates and frees int objects, and also converts objects to

 *	have int type.

 *

 *----------------------------------------------------------------------

 */

static int

TestindexobjCmd(clientData, interp, objc, objv)

    ClientData clientData;	/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    int allowAbbrev, index, index2, setError, i, result;

    CONST char **argv;

    static CONST char *tablePtr[] = {"a", "b", "check", (char *) NULL};

    /*

     * Keep this structure declaration in sync with tclIndexObj.c

     */

    struct IndexRep {

	VOID *tablePtr;			/* Pointer to the table of strings */

	int offset;			/* Offset between table entries */

	int index;			/* Selected index into table. */

    };

    struct IndexRep *indexRep;

    if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),

	    "check") == 0)) {

	/*

	 * This code checks to be sure that the results of

	 * Tcl_GetIndexFromObj are properly cached in the object and

	 * returned on subsequent lookups.

	 */

	if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {

	    return TCL_ERROR;

	}

	Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,

		"token", 0, &index);

	indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;

	indexRep->index = index2;

	result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],

		tablePtr, "token", 0, &index);

	if (result == TCL_OK) {

	    Tcl_SetIntObj(Tcl_GetObjResult(interp), index);

	}

	return result;

    }

    if (objc < 5) {

	Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);

	return TCL_ERROR;

    }

    if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {

	return TCL_ERROR;

    }

    if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {

	return TCL_ERROR;

    }

    argv = (CONST char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));

    for (i = 4; i < objc; i++) {

	argv[i-4] = Tcl_GetString(objv[i]);

    }

    argv[objc-4] = NULL;

    /*

     * Tcl_GetIndexFromObj assumes that the table is statically-allocated

     * so that its address is different for each index object. If we

     * accidently allocate a table at the same address as that cached in

     * the index object, clear out the object's cached state.

     */

    if ( objv[3]->typePtr != NULL

	 && !strcmp( "index", objv[3]->typePtr->name ) ) {

	indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;

	if (indexRep->tablePtr == (VOID *) argv) {

	    objv[3]->typePtr->freeIntRepProc(objv[3]);

	    objv[3]->typePtr = NULL;

	}

    }

    result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],

	    argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);

    ckfree((char *) argv);

    if (result == TCL_OK) {

	Tcl_SetIntObj(Tcl_GetObjResult(interp), index);

    }

    return result;

}

/*

 *----------------------------------------------------------------------

 *

 * TestintobjCmd --

 *

 *	This procedure implements the "testintobj" command. It is used to

 *	test the int Tcl object type implementation.

 *

 * Results:

 *	A standard Tcl object result.

 *

 * Side effects:

 *	Creates and frees int objects, and also converts objects to

 *	have int type.

 *

 *----------------------------------------------------------------------

 */

static int

TestintobjCmd(clientData, interp, objc, objv)

    ClientData clientData;	/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    int intValue, varIndex, i;

    long longValue;

    char *index, *subCmd, *string;

    if (objc < 3) {

	wrongNumArgs:

	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");

	return TCL_ERROR;

    }

    index = Tcl_GetString(objv[2]);

    if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {

	return TCL_ERROR;

    }

    subCmd = Tcl_GetString(objv[1]);

    if (strcmp(subCmd, "set") == 0) {

	if (objc != 4) {