tcltestobj.c

来自「tcl是工具命令语言」· C语言 代码 · 共 1,193 行 · 第 1/3 页

	    return TCL_ERROR;
	}
        if (CheckIfVarUnset(interp, varIndex)) {
	    return TCL_ERROR;
	}
	Tcl_InvalidateStringRep( varPtr[varIndex] );
	Tcl_SetObjResult( interp, varPtr[varIndex] );
    } 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 CONST char *options[] = {
	"append", "appendstrings", "get", "get2", "length", "length2",
	"set", "set2", "setlength", "ualloc", "getunicode", 
	(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;
	case 10:			/* getunicode */
	    if (objc != 3) {
		goto wrongNumArgs;
	    }
	    Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
	    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;
}