tclunixtest.c

tcl是工具命令语言

 *----------------------------------------------------------------------
 *
 * TestfilewaitCmd --
 *
 *	This procedure implements the "testfilewait" command. It is
 *	used to test TclUnixWaitForFile.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestfilewaitCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int mask, result, timeout;
    Tcl_Channel channel;
    int fd;
    ClientData data;

    if (argc != 4) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		" file readable|writable|both timeout\"", (char *) NULL);
	return TCL_ERROR;
    }
    channel = Tcl_GetChannel(interp, argv[1], NULL);
    if (channel == NULL) {
	return TCL_ERROR;
    }
    if (strcmp(argv[2], "readable") == 0) {
	mask = TCL_READABLE;
    } else if (strcmp(argv[2], "writable") == 0){
	mask = TCL_WRITABLE;
    } else if (strcmp(argv[2], "both") == 0){
	mask = TCL_WRITABLE|TCL_READABLE;
    } else {
	Tcl_AppendResult(interp, "bad argument \"", argv[2],
		"\": must be readable, writable, or both", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetChannelHandle(channel, 
	    (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
	    (ClientData*) &data) != TCL_OK) {
	Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
	return TCL_ERROR;
    }
    fd = (int) data;
    if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
	return TCL_ERROR;
    }
    result = TclUnixWaitForFile(fd, mask, timeout);
    if (result & TCL_READABLE) {
	Tcl_AppendElement(interp, "readable");
    }
    if (result & TCL_WRITABLE) {
	Tcl_AppendElement(interp, "writable");
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestfindexecutableCmd --
 *
 *	This procedure implements the "testfindexecutable" command. It is
 *	used to test Tcl_FindExecutable.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestfindexecutableCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    char *oldName;
    char *oldNativeName;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		" argv0\"", (char *) NULL);
	return TCL_ERROR;
    }

    oldName       = tclExecutableName;
    oldNativeName = tclNativeExecutableName;

    tclExecutableName       = NULL;
    tclNativeExecutableName = NULL;

    Tcl_FindExecutable(argv[1]);
    if (tclExecutableName != NULL) {
	Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE);
	ckfree(tclExecutableName);
    }
    if (tclNativeExecutableName != NULL) {
	ckfree(tclNativeExecutableName);
    }

    tclExecutableName       = oldName;
    tclNativeExecutableName = oldNativeName;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestgetopenfileCmd --
 *
 *	This procedure implements the "testgetopenfile" command. It is
 *	used to get a FILE * value from a registered channel.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestgetopenfileCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    ClientData filePtr;

    if (argc != 3) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                " channelName forWriting\"",
                (char *) NULL);
        return TCL_ERROR;
    }
    if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr)
            == TCL_ERROR) {
        return TCL_ERROR;
    }
    if (filePtr == (ClientData) NULL) {
        Tcl_AppendResult(interp,
                "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL);
        return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestsetdefencdirCmd --
 *
 *	This procedure implements the "testsetdefenc" command. It is
 *	used to set the value of tclDefaultEncodingDir.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestsetdefencdirCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                " defaultDir\"",
                (char *) NULL);
        return TCL_ERROR;
    }

    if (tclDefaultEncodingDir != NULL) {
	ckfree(tclDefaultEncodingDir);
	tclDefaultEncodingDir = NULL;
    }
    if (*argv[1] != '\0') {
	tclDefaultEncodingDir = (char *)
	    ckalloc((unsigned) strlen(argv[1]) + 1);
	strcpy(tclDefaultEncodingDir, argv[1]);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestgetdefencdirCmd --
 *
 *	This procedure implements the "testgetdefenc" command. It is
 *	used to get the value of tclDefaultEncodingDir.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
TestgetdefencdirCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    if (argc != 1) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                (char *) NULL);
        return TCL_ERROR;
    }

    if (tclDefaultEncodingDir != NULL) {
        Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 * TestalarmCmd --
 *
 *	Test that EINTR is handled correctly by generating and
 *	handling a signal.  This requires using the SA_RESTART
 *	flag when registering the signal handler.
 *
 * Results:
 *	None.
 *
 * Side Effects:
 *	Sets up an signal and async handlers.
 *
 *----------------------------------------------------------------------
 */

static int
TestalarmCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
#ifdef SA_RESTART
    unsigned int sec;
    struct sigaction action;

    if (argc > 1) {
	Tcl_GetInt(interp, argv[1], (int *)&sec);
    } else {
	sec = 1;
    }

    /*
     * Setup the signal handling that automatically retries
     * any interupted I/O system calls.
     */
    action.sa_handler = AlarmHandler;
    memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
    action.sa_flags = SA_RESTART;

    if (sigaction(SIGALRM, &action, NULL) < 0) {
	Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
	return TCL_ERROR;
    }
    if (alarm(sec) < 0) {
	Tcl_AppendResult(interp, "alarm: ", Tcl_PosixError(interp), NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
#else
    Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL);
    return TCL_ERROR;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * AlarmHandler --
 *
 *	Signal handler for the alarm command.
 *
 * Results:
 *	None.
 *
 * Side effects:
 * 	Calls the Tcl Async handler.
 *
 *----------------------------------------------------------------------
 */

static void
AlarmHandler()
{
    gotsig = "1";
}

/*
 *----------------------------------------------------------------------
 * TestgotsigCmd --
 *
 * 	Verify the signal was handled after the testalarm command.
 *
 * Results:
 *	None.
 *
 * Side Effects:
 *	Resets the value of gotsig back to '0'.
 *
 *----------------------------------------------------------------------
 */

static int
TestgotsigCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_AppendResult(interp, gotsig, (char *) NULL);
    gotsig = "0";
    return TCL_OK;
}