tcliocmd.c

tcl是工具命令语言

 */

	/* ARGSUSED */
int
Tcl_CloseObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;			/* The channel to close. */
    char *arg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
	return TCL_ERROR;
    }

    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, NULL);
    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
        /*
         * If there is an error message and it ends with a newline, remove
         * the newline. This is done for command pipeline channels where the
         * error output from the subprocesses is stored in interp's result.
         *
         * NOTE: This is likely to not have any effect on regular error
         * messages produced by drivers during the closing of a channel,
         * because the Tcl convention is that such error messages do not
         * have a terminating newline.
         */

	Tcl_Obj *resultPtr;
	char *string;
	int len;
	
	resultPtr = Tcl_GetObjResult(interp);
	string = Tcl_GetStringFromObj(resultPtr, &len);
        if ((len > 0) && (string[len - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, len - 1);
        }
        return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FconfigureObjCmd --
 *
 *	This procedure is invoked to process the Tcl "fconfigure" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May modify the behavior of an IO channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FconfigureObjCmd(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 *chanName, *optionName, *valueName;
    Tcl_Channel chan;			/* The channel to set a mode on. */
    int i;				/* Iterate over arg-value pairs. */
    Tcl_DString ds;			/* DString to hold result of
                                         * calling Tcl_GetChannelOption. */

    if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"channelId ?optionName? ?value? ?optionName value?...");
        return TCL_ERROR;
    }
    chanName = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, chanName, NULL);
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }
    if (objc == 2) {
        Tcl_DStringInit(&ds);
        if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
	    Tcl_DStringFree(&ds);
	    return TCL_ERROR;
        }
        Tcl_DStringResult(interp, &ds);
        return TCL_OK;
    }
    if (objc == 3) {
        Tcl_DStringInit(&ds);
	optionName = Tcl_GetString(objv[2]);
        if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
            Tcl_DStringFree(&ds);
            return TCL_ERROR;
        }
        Tcl_DStringResult(interp, &ds);
        return TCL_OK;
    }
    for (i = 3; i < objc; i += 2) {
	optionName = Tcl_GetString(objv[i-1]);
	valueName = Tcl_GetString(objv[i]);
        if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
		!= TCL_OK) {
            return TCL_ERROR;
        }
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_EofObjCmd --
 *
 *	This procedure is invoked to process the Tcl "eof" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether
 *	the specified channel has an EOF condition.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_EofObjCmd(unused, interp, objc, objv)
    ClientData unused;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;
    int dummy;
    char *arg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
        return TCL_ERROR;
    }

    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, &dummy);
    if (chan == NULL) {
	return TCL_ERROR;
    }

    Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ExecObjCmd --
 *
 *	This procedure is invoked to process the "exec" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ExecObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
#ifdef MAC_TCL

    Tcl_AppendResult(interp, "exec not implemented under Mac OS",
		(char *)NULL);
    return TCL_ERROR;

#else /* !MAC_TCL */

    /*
     * This procedure generates an argv array for the string arguments. It
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */

#define NUM_ARGS 20
    Tcl_Obj *resultPtr;
    CONST char **argv;
    char *string;
    Tcl_Channel chan;
    CONST char *argStorage[NUM_ARGS];
    int argc, background, i, index, keepNewline, result, skip, length;
    static CONST char *options[] = {
	"-keepnewline",	"--",		NULL
    };
    enum options {
	EXEC_KEEPNEWLINE, EXEC_LAST
    };

    /*
     * Check for a leading "-keepnewline" argument.
     */

    keepNewline = 0;
    for (skip = 1; skip < objc; skip++) {
	string = Tcl_GetString(objv[skip]);
	if (string[0] != '-') {
	    break;
	}
	if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
		TCL_EXACT, &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (index == EXEC_KEEPNEWLINE) {
	    keepNewline = 1;
	} else {
	    skip++;
	    break;
	}
    }
    if (objc <= skip) {
	Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * See if the command is to be run in background.
     */

    background = 0;
    string = Tcl_GetString(objv[objc - 1]);
    if ((string[0] == '&') && (string[1] == '\0')) {
	objc--;
        background = 1;
    }

    /*
     * Create the string argument array "argv". Make sure argv is large
     * enough to hold the argc arguments plus 1 extra for the zero
     * end-of-argv word.
     */

    argv = argStorage;
    argc = objc - skip;
    if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
	argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
    }

    /*
     * Copy the string conversions of each (post option) object into the
     * argument vector.
     */

    for (i = 0; i < argc; i++) {
	argv[i] = Tcl_GetString(objv[i + skip]);
    }
    argv[argc] = NULL;
    chan = Tcl_OpenCommandChannel(interp, argc, argv,
            (background ? 0 : TCL_STDOUT | TCL_STDERR));

    /*
     * Free the argv array if malloc'ed storage was used.
     */

    if (argv != argStorage) {
	ckfree((char *)argv);
    }

    if (chan == (Tcl_Channel) NULL) {
	return TCL_ERROR;
    }

    if (background) {
        /*
	 * Store the list of PIDs from the pipeline in interp's result and
	 * detach the PIDs (instead of waiting for them).
	 */

        TclGetAndDetachPids(interp, chan);
        if (Tcl_Close(interp, chan) != TCL_OK) {
	    return TCL_ERROR;
        }
	return TCL_OK;
    }

    resultPtr = Tcl_NewObj();
    if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
	if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading output from command: ",
		    Tcl_PosixError(interp), (char *) NULL);
	    Tcl_DecrRefCount(resultPtr);
	    return TCL_ERROR;
	}
    }
    /*
     * If the process produced anything on stderr, it will have been
     * returned in the interpreter result.  It needs to be appended to
     * the result string.
     */

    result = Tcl_Close(interp, chan);
    string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
    Tcl_AppendToObj(resultPtr, string, length);

    /*
     * If the last character of the result is a newline, then remove
     * the newline character.
     */
    
    if (keepNewline == 0) {
	string = Tcl_GetStringFromObj(resultPtr, &length);
	if ((length > 0) && (string[length - 1] == '\n')) {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);

    return result;
#endif /* !MAC_TCL */
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FblockedObjCmd --
 *
 *	This procedure is invoked to process the Tcl "fblocked" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Sets interp's result to boolean true or false depending on whether
 *	the preceeding input operation on the channel would have blocked.
 *
 *---------------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_FblockedObjCmd(unused, interp, objc, objv)
    ClientData unused;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Channel chan;
    int mode;
    char *arg;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "channelId");
        return TCL_ERROR;
    }

    arg = Tcl_GetString(objv[1]);
    chan = Tcl_GetChannel(interp, arg, &mode);
    if (chan == NULL) {
        return TCL_ERROR;
    }
    if ((mode & TCL_READABLE) == 0) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
		arg, "\" wasn't opened for reading", (char *) NULL);
        return TCL_ERROR;
    }
        
    Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan));
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_OpenObjCmd --
 *
 *	This procedure is invoked to process the "open" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_OpenObjCmd(notUsed, interp, objc, objv)
    ClientData notUsed;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int pipeline, prot;
    char *modeString, *what;
    Tcl_Channel chan;

    if ((objc < 2) || (objc > 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
	return TCL_ERROR;
    }
    prot = 0666;
    if (objc == 2) {
	modeString = "r";
    } else {
	modeString = Tcl_GetString(objv[2]);
	if (objc == 4) {
	    if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
		return TCL_ERROR;
	    }
	}
    }

    pipeline = 0;
    what = Tcl_GetString(objv[1]);
    if (what[0] == '|') {
	pipeline = 1;
    }

    /*
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {
        chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
    } else {
#ifdef MAC_TCL
	Tcl_AppendResult(interp,
		"command pipelines not supported on Macintosh OS",
		(char *)NULL);
	return TCL_ERROR;
#else
	int mode, seekFlag, cmdObjc;
	CONST char **cmdArgv;

        if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
            return TCL_ERROR;
        }

        mode = TclGetOpenMode(interp, modeString, &seekFlag);
        if (mode == -1) {
	    chan = NULL;
        } else {
	    int flags = TCL_STDERR | TCL_ENFORCE_MODE;
	    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
		case O_RDONLY:
		    flags |= TCL_STDOUT;
		    break;
		case O_WRONLY:
		    flags |= TCL_STDIN;
		    break;
		case O_RDWR:
		    flags |= (TCL_STDIN | TCL_STDOUT);
		    break;
		default:
		    panic("Tcl_OpenCmd: invalid mode value");
		    break;
	    }
	    chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
	}
        ckfree((char *) cmdArgv);
#endif
    }
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }
    Tcl_RegisterChannel(interp, chan);
    Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TcpAcceptCallbacksDeleteProc --
 *
 *	Assocdata cleanup routine called when an interpreter is being
 *	deleted to set the interp field of all the accept callback records
 *	registered with	the interpreter to NULL. This will prevent the
 *	interpreter from being used in the future to eval accept scripts.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deallocates memory and sets the interp field of all the accept
 *	callback records to NULL to prevent this interpreter from being
 *	used subsequently to eval accept scripts.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void