diff options
Diffstat (limited to 'generic/tclTestObj.c')
| -rw-r--r-- | generic/tclTestObj.c | 1110 |
1 files changed, 0 insertions, 1110 deletions
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c deleted file mode 100644 index d604c5b..0000000 --- a/generic/tclTestObj.c +++ /dev/null @@ -1,1110 +0,0 @@ -/* - * 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. - * - * 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.3 1999/04/16 00:46:54 stanton 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[])); - -/* - *---------------------------------------------------------------------- - * - * 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; - char **argv; - static char *tablePtr[] = {"a", "b", "check", (char *) NULL}; - - 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. - */ - - Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, - "token", 0, &index); - if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { - return TCL_ERROR; - } - objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) 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 = (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 == Tcl_GetObjType("index")) - && (objv[3]->internalRep.twoPtrValue.ptr1 == (VOID *) argv)) { - 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) { - goto wrongNumArgs; - } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { - return TCL_ERROR; - } - intValue = i; - - /* - * 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_SetIntObj(varPtr[varIndex], intValue); - } else { - SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); - } - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ - if (objc != 4) { - goto wrongNumArgs; - } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { - return TCL_ERROR; - } - intValue = i; - if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue); - } else { - SetVarToObj(varIndex, Tcl_NewIntObj(intValue)); - } - } else if (strcmp(subCmd, "setlong") == 0) { - if (objc != 4) { - goto wrongNumArgs; - } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { - return TCL_ERROR; - } - intValue = i; - if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetLongObj(varPtr[varIndex], intValue); - } else { - SetVarToObj(varIndex, Tcl_NewLongObj(intValue)); - } - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "setmaxlong") == 0) { - long maxLong = LONG_MAX; - if (objc != 3) { - goto wrongNumArgs; - } - if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetLongObj(varPtr[varIndex], maxLong); - } else { - SetVarToObj(varIndex, Tcl_NewLongObj(maxLong)); - } - } else if (strcmp(subCmd, "ismaxlong") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) { - return TCL_ERROR; - } - Tcl_AppendToObj(Tcl_GetObjResult(interp), - ((longValue == LONG_MAX)? "1" : "0"), -1); - } 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, "get2") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - string = Tcl_GetString(varPtr[varIndex]); - Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); - } else if (strcmp(subCmd, "inttoobigtest") == 0) { - /* - * If long ints have more bits than ints on this platform, verify - * that Tcl_GetIntFromObj returns an error if the long int held - * in an integer object's internal representation is too large - * to fit in an int. - */ - - if (objc != 3) { - goto wrongNumArgs; - } -#if (INT_MAX == LONG_MAX) /* int is same size as long int */ - Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); -#else - if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetLongObj(varPtr[varIndex], LONG_MAX); - } else { - SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX)); - } - if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); - return TCL_OK; - } - Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1); -#endif - } else if (strcmp(subCmd, "mult10") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { - return TCL_ERROR; - } - if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], (intValue * 10)); - } else { - SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) )); - } - 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_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { - return TCL_ERROR; - } - if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], (intValue / 10)); - } else { - SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) )); - } - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetString(objv[1]), - "\": must be set, get, get2, mult10, or div10", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestobjCmd -- - * - * This procedure implements the "testobj" command. It is used to test - * the type-independent portions of the Tcl object type implementation. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * Creates and frees objects. - * - *---------------------------------------------------------------------- - */ - -static int -TestobjCmd(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, destIndex, i; - char *index, *subCmd, *string; - Tcl_ObjType *targetType; - - if (objc < 2) { - wrongNumArgs: - Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); - return TCL_ERROR; - } - - subCmd = Tcl_GetString(objv[1]); - if (strcmp(subCmd, "assign") == 0) { - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(destIndex, varPtr[varIndex]); - Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "convert") == 0) { - char *typeName; - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - typeName = Tcl_GetString(objv[3]); - if ((targetType = Tcl_GetObjType(typeName)) == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no type ", typeName, " found", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) - != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "duplicate") == 0) { - if (objc != 4) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex])); - Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "freeallvars") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - if (varPtr[i] != NULL) { - Tcl_DecrRefCount(varPtr[i]); - varPtr[i] = NULL; - } - } - } else if (strcmp(subCmd, "newobj") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - SetVarToObj(varIndex, Tcl_NewObj()); - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "refcount") == 0) { - char buf[TCL_INTEGER_SPACE]; - - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - TclFormatInt(buf, varPtr[varIndex]->refCount); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if (strcmp(subCmd, "type") == 0) { - if (objc != 3) { - goto wrongNumArgs; - } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ - Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - varPtr[varIndex]->typePtr->name, -1); - } - } else if (strcmp(subCmd, "types") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - if (Tcl_AppendAllObjTypes(interp, Tcl_GetObjResult(interp)) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", - Tcl_GetString(objv[1]), - "\": must be assign, convert, duplicate, freeallvars, ", - "newobj, objcount, refcount, type, or types", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TeststringobjCmd -- - * - * This procedure implements the "teststringobj" command. It is used to - * test the string Tcl object type implementation. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * Creates and frees string objects, and also converts objects to - * have string type. - * - *---------------------------------------------------------------------- - */ - -static int -TeststringobjCmd(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, option, i, length; -#define MAX_STRINGS 11 - char *index, *string, *strings[MAX_STRINGS+1]; - static char *options[] = { - "append", "appendstrings", "get", "get2", "length", "length2", - "set", "set2", "setlength", (char *) NULL - }; - - 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; - } - - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option) - != TCL_OK) { - return TCL_ERROR; - } - switch (option) { - case 0: /* append */ - if (objc != 5) { - goto wrongNumArgs; - } - if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { - return TCL_ERROR; - } - if (varPtr[varIndex] == NULL) { - SetVarToObj(varIndex, Tcl_NewObj()); - } - - /* - * If the object bound to variable "varIndex" is shared, we must - * "copy on write" and append to a copy of the object. - */ - - if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); - } - string = Tcl_GetString(objv[3]); - Tcl_AppendToObj(varPtr[varIndex], string, length); - Tcl_SetObjResult(interp, varPtr[varIndex]); - break; - case 1: /* appendstrings */ - if (objc > (MAX_STRINGS+3)) { - goto wrongNumArgs; - } - if (varPtr[varIndex] == NULL) { - SetVarToObj(varIndex, Tcl_NewObj()); - } - - /* - * If the object bound to variable "varIndex" is shared, we must - * "copy on write" and append to a copy of the object. - */ - - if (Tcl_IsShared(varPtr[varIndex])) { - SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); - } - for (i = 3; i < objc; i++) { - strings[i-3] = Tcl_GetString(objv[i]); - } - for ( ; i < 12 + 3; i++) { - strings[i - 3] = NULL; - } - Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1], - strings[2], strings[3], strings[4], strings[5], - strings[6], strings[7], strings[8], strings[9], - strings[10], strings[11]); - Tcl_SetObjResult(interp, varPtr[varIndex]); - break; - case 2: /* get */ - if (objc != 3) { - goto wrongNumArgs; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, varPtr[varIndex]); - break; - case 3: /* get2 */ - if (objc != 3) { - goto wrongNumArgs; - } - if (CheckIfVarUnset(interp, varIndex)) { - return TCL_ERROR; - } - string = Tcl_GetString(varPtr[varIndex]); - Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); - break; - case 4: /* length */ - if (objc != 3) { - goto wrongNumArgs; - } - Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) - ? varPtr[varIndex]->length : -1); - break; - case 5: /* length2 */ - if (objc != 3) { - goto wrongNumArgs; - } - Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) - ? (int) varPtr[varIndex]->internalRep.longValue : -1); - break; - case 6: /* set */ - if (objc != 4) { - goto wrongNumArgs; - } - - /* - * 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". - */ - - string = Tcl_GetStringFromObj(objv[3], &length); - if ((varPtr[varIndex] != NULL) - && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetStringObj(varPtr[varIndex], string, length); - } else { - SetVarToObj(varIndex, Tcl_NewStringObj(string, length)); - } - Tcl_SetObjResult(interp, varPtr[varIndex]); - break; - case 7: /* set2 */ - if (objc != 4) { - goto wrongNumArgs; - } - SetVarToObj(varIndex, objv[3]); - break; - case 8: /* setlength */ - if (objc != 4) { - goto wrongNumArgs; - } - if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) { - return TCL_ERROR; - } - if (varPtr[varIndex] != NULL) { - Tcl_SetObjLength(varPtr[varIndex], length); - } - break; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SetVarToObj -- - * - * Utility routine to assign a Tcl_Obj* to a test variable. The - * Tcl_Obj* can be NULL. - * - * Results: - * None. - * - * Side effects: - * This routine handles ref counting details for assignment: - * i.e. the old value's ref count must be decremented (if not NULL) and - * the new one incremented (also if not NULL). - * - *---------------------------------------------------------------------- - */ - -static void -SetVarToObj(varIndex, objPtr) - int varIndex; /* Designates the assignment variable. */ - Tcl_Obj *objPtr; /* Points to object to assign to var. */ -{ - if (varPtr[varIndex] != NULL) { - Tcl_DecrRefCount(varPtr[varIndex]); - } - varPtr[varIndex] = objPtr; - if (objPtr != NULL) { - Tcl_IncrRefCount(objPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * GetVariableIndex -- - * - * Utility routine to get a test variable index from the command line. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -GetVariableIndex(interp, string, indexPtr) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - char *string; /* String containing a variable index - * specified as a nonnegative number less - * than NUMBER_OF_OBJECT_VARS. */ - int *indexPtr; /* Place to store converted result. */ -{ - int index; - - if (Tcl_GetInt(interp, string, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1); - return TCL_ERROR; - } - - *indexPtr = index; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * CheckIfVarUnset -- - * - * Utility procedure that checks whether a test variable is readable: - * i.e., that varPtr[varIndex] is non-NULL. - * - * Results: - * 1 if the test variable is unset (NULL); 0 otherwise. - * - * Side effects: - * Sets the interpreter result to an error message if the variable is - * unset (NULL). - * - *---------------------------------------------------------------------- - */ - -static int -CheckIfVarUnset(interp, varIndex) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - int varIndex; /* Index of the test variable to check. */ -{ - if (varPtr[varIndex] == NULL) { - char buf[32 + TCL_INTEGER_SPACE]; - - sprintf(buf, "variable %d is unset (NULL)", varIndex); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - return 1; - } - return 0; -} |