Logo Search packages:      
Sourcecode: tcl8.3 version File versions  Download package

tclTestObj.c

/* 
 * 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.6.10.1 2001/04/03 22:54:38 hobbs 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;
    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 * sizeof(char *));
      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, "objtype") == 0) {
      char *typeName;

      /*
       * return an object containing the name of the argument's type
       * of internal rep.  If none exists, return "none".
       */
      
        if (objc != 3) {
            goto wrongNumArgs;
        }
      if (objv[2]->typePtr == NULL) {
          Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
      } else {
          typeName = objv[2]->typePtr->name;
          Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
      }
    } 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, objtype, 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];
    TestString *strPtr;
    static char *options[] = {
      "append", "appendstrings", "get", "get2", "length", "length2",
      "set", "set2", "setlength", "ualloc", (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;
          }
          if (varPtr[varIndex] != NULL) {
            strPtr = (TestString *)
                (varPtr[varIndex])->internalRep.otherValuePtr;
            length = (int) strPtr->allocated;
          } else {
            length = -1;
          }
          Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
          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;
      case 9:                       /* ualloc */
          if (objc != 3) {
            goto wrongNumArgs;
          }
          if (varPtr[varIndex] != NULL) {
            strPtr = (TestString *)
                (varPtr[varIndex])->internalRep.otherValuePtr;
            length = (int) strPtr->uallocated;
          } else {
            length = -1;
          }
          Tcl_SetIntObj(Tcl_GetObjResult(interp), 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;
}

Generated by  Doxygen 1.6.0   Back to index