tcltest.c

tcl是工具命令语言

	if (argc != 2) {
	    goto wrongNumArgs;
	}
	Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE);
    } else if (strcmp(argv[1], "gresult") == 0) {
	if (argc != 3) {
	    goto wrongNumArgs;
	}
	if (strcmp(argv[2], "staticsmall") == 0) {
	    Tcl_SetResult(interp, "short", TCL_STATIC);
	} else if (strcmp(argv[2], "staticlarge") == 0) {
	    Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
	} else if (strcmp(argv[2], "free") == 0) {
	    Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC);
	    strcpy(interp->result, "This is a malloc-ed string");
	} else if (strcmp(argv[2], "special") == 0) {
	    interp->result = (char *) ckalloc(100);
	    interp->result += 4;
	    interp->freeProc = SpecialFree;
	    strcpy(interp->result, "This is a specially-allocated string");
	} else {
	    Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
		    "\": must be staticsmall, staticlarge, free, or special",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	Tcl_DStringGetResult(interp, &dstring);
    } else if (strcmp(argv[1], "length") == 0) {
	char buf[TCL_INTEGER_SPACE];
	
	if (argc != 2) {
	    goto wrongNumArgs;
	}
	TclFormatInt(buf, Tcl_DStringLength(&dstring));
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
    } else if (strcmp(argv[1], "result") == 0) {
	if (argc != 2) {
	    goto wrongNumArgs;
	}
	Tcl_DStringResult(interp, &dstring);
    } else if (strcmp(argv[1], "trunc") == 0) {
	if (argc != 3) {
	    goto wrongNumArgs;
	}
	if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
	    return TCL_ERROR;
	}
	Tcl_DStringTrunc(&dstring, count);
    } else if (strcmp(argv[1], "start") == 0) {
	if (argc != 2) {
	    goto wrongNumArgs;
	}
	Tcl_DStringStartSublist(&dstring);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be append, element, end, free, get, length, ",
		"result, trunc, or start", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * The procedure below is used as a special freeProc to test how well
 * Tcl_DStringGetResult handles freeProc's other than free.
 */

static void SpecialFree(blockPtr)
    char *blockPtr;			/* Block to free. */
{
    ckfree(blockPtr - 4);
}

/*
 *----------------------------------------------------------------------
 *
 * TestencodingCmd --
 *
 *	This procedure implements the "testencoding" command.  It is used
 *	to test the encoding package.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Load encodings.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
TestencodingObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Encoding encoding;
    int index, length;
    char *string;
    TclEncoding *encodingPtr;
    static CONST char *optionStrings[] = {
	"create",	"delete",	"path",
	NULL
    };
    enum options {
	ENC_CREATE,	ENC_DELETE,	ENC_PATH
    };
    
    if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
	    &index) != TCL_OK) {
	return TCL_ERROR;
    }

    switch ((enum options) index) {
	case ENC_CREATE: {
	    Tcl_EncodingType type;

	    if (objc != 5) {
		return TCL_ERROR;
	    }
	    encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
	    encodingPtr->interp = interp;

	    string = Tcl_GetStringFromObj(objv[3], &length);
	    encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
	    memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);

	    string = Tcl_GetStringFromObj(objv[4], &length);
	    encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
	    memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));

	    string = Tcl_GetStringFromObj(objv[2], &length);

	    type.encodingName = string;
	    type.toUtfProc = EncodingToUtfProc;
	    type.fromUtfProc = EncodingFromUtfProc;
	    type.freeProc = EncodingFreeProc;
	    type.clientData = (ClientData) encodingPtr;
	    type.nullSize = 1;

	    Tcl_CreateEncoding(&type);
	    break;
	}
	case ENC_DELETE: {
	    if (objc != 3) {
		return TCL_ERROR;
	    }
	    encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
	    Tcl_FreeEncoding(encoding);
	    Tcl_FreeEncoding(encoding);
	    break;
	}
	case ENC_PATH: {
	    if (objc == 2) {
		Tcl_SetObjResult(interp, TclGetLibraryPath());
	    } else {
		TclSetLibraryPath(objv[2]);
	    }
	    break;
	}
    }
    return TCL_OK;
}
static int 
EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TclEncoding structure. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Current state. */
    char *dst;			/* Output buffer. */
    int dstLen;			/* The maximum length of output buffer. */
    int *srcReadPtr;		/* Filled with number of bytes read. */
    int *dstWrotePtr;		/* Filled with number of bytes stored. */
    int *dstCharsPtr;		/* Filled with number of chars stored. */
{
    int len;
    TclEncoding *encodingPtr;

    encodingPtr = (TclEncoding *) clientData;
    Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);

    len = strlen(Tcl_GetStringResult(encodingPtr->interp));
    if (len > dstLen) {
	len = dstLen;
    }
    memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
    Tcl_ResetResult(encodingPtr->interp);

    *srcReadPtr = srcLen;
    *dstWrotePtr = len;
    *dstCharsPtr = len;
    return TCL_OK;
}
static int 
EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
	srcReadPtr, dstWrotePtr, dstCharsPtr)
    ClientData clientData;	/* TclEncoding structure. */
    CONST char *src;		/* Source string in specified encoding. */
    int srcLen;			/* Source string length in bytes. */
    int flags;			/* Conversion control flags. */
    Tcl_EncodingState *statePtr;/* Current state. */
    char *dst;			/* Output buffer. */
    int dstLen;			/* The maximum length of output buffer. */
    int *srcReadPtr;		/* Filled with number of bytes read. */
    int *dstWrotePtr;		/* Filled with number of bytes stored. */
    int *dstCharsPtr;		/* Filled with number of chars stored. */
{
    int len;
    TclEncoding *encodingPtr;

    encodingPtr = (TclEncoding *) clientData;
    Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);

    len = strlen(Tcl_GetStringResult(encodingPtr->interp));
    if (len > dstLen) {
	len = dstLen;
    }
    memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
    Tcl_ResetResult(encodingPtr->interp);

    *srcReadPtr = srcLen;
    *dstWrotePtr = len;
    *dstCharsPtr = len;
    return TCL_OK;
}
static void
EncodingFreeProc(clientData)
    ClientData clientData;	/* ClientData associated with type. */
{
    TclEncoding *encodingPtr;

    encodingPtr = (TclEncoding *) clientData;
    ckfree((char *) encodingPtr->toUtfCmd);
    ckfree((char *) encodingPtr->fromUtfCmd);
    ckfree((char *) encodingPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TestevalexObjCmd --
 *
 *	This procedure implements the "testevalex" command.  It is
 *	used to test Tcl_EvalEx.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestevalexObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    int code, oldFlags, length, flags;
    char *string;

    if (objc == 1) {
	/*
	 * The command was invoked with no arguments, so just toggle
	 * the flag that determines whether we use Tcl_EvalEx.
	 */

	if (iPtr->flags & USE_EVAL_DIRECT) {
	    iPtr->flags &= ~USE_EVAL_DIRECT;
	    Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC);
	} else {
	    iPtr->flags |= USE_EVAL_DIRECT;
	    Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC);
	}
	return TCL_OK;
    }

    flags = 0;
    if (objc == 3) {
	string = Tcl_GetStringFromObj(objv[2], &length);
	if (strcmp(string, "global") != 0) {
	    Tcl_AppendResult(interp, "bad value \"", string,
		    "\": must be global", (char *) NULL);
	    return TCL_ERROR;
	}
	flags = TCL_EVAL_GLOBAL;
    } else if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
        return TCL_ERROR;
    }
    Tcl_SetResult(interp, "xxx", TCL_STATIC);

    /*
     * Note, we have to set the USE_EVAL_DIRECT flag in the interpreter
     * in addition to calling Tcl_EvalEx.  This is needed so that even nested
     * commands are evaluated directly.
     */

    oldFlags = iPtr->flags;
    iPtr->flags |= USE_EVAL_DIRECT;
    string = Tcl_GetStringFromObj(objv[1], &length);
    code = Tcl_EvalEx(interp, string, length, flags); 
    iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT)
	    | (oldFlags & USE_EVAL_DIRECT);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TestevalobjvObjCmd --
 *
 *	This procedure implements the "testevalobjv" command.  It is
 *	used to test Tcl_EvalObjv.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestevalobjvObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int evalGlobal;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");
        return TCL_ERROR;
    }
    if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {
	return TCL_ERROR;
    }
    return Tcl_EvalObjv(interp, objc-2, objv+2,
	    (evalGlobal) ? TCL_EVAL_GLOBAL : 0);
}

/*
 *----------------------------------------------------------------------
 *
 * TesteventObjCmd --
 *
 *	This procedure implements a 'testevent' command.  The command
 *	is used to test event queue management.
 *
 * The command takes two forms:
 *	- testevent queue name position script
 *		Queues an event at the given position in the queue, and
 *		associates a given name with it (the same name may be
 *		associated with multiple events). When the event comes
 *		to the head of the queue, executes the given script at
 *		global level in the current interp. The position may be
 *		one of 'head', 'tail' or 'mark'.
 *	- testevent delete name
 *		Deletes any events associated with the given name from
 *		the queue.
 *
 * Return value:
 *	Returns a standard Tcl result.
 *
 * Side effects:
 *	Manipulates the event queue as directed.
 *
 *----------------------------------------------------------------------
 */

static int
TesteventObjCmd( ClientData unused,      /* Not used */
		 Tcl_Interp* interp,     /* Tcl interpreter */
		 int objc,               /* Parameter count */
		 Tcl_Obj *CONST objv[] ) /* Parameter vector */
{
    
    static CONST