tclpipe.c

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

/* 
 * tclPipe.c --
 *
 *	This file contains the generic portion of the command channel
 *	driver as well as various utility routines used in managing
 *	subprocesses.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPipe.c,v 1.7 2002/12/17 02:47:39 davygrvy Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * A linked list of the following structures is used to keep track
 * of child processes that have been detached but haven't exited
 * yet, so we can make sure that they're properly "reaped" (officially
 * waited for) and don't lie around as zombies cluttering the
 * system.
 */

typedef struct Detached {
    Tcl_Pid pid;			/* Id of process that's been detached
					 * but isn't known to have exited. */
    struct Detached *nextPtr;		/* Next in list of all detached
					 * processes. */
} Detached;

static Detached *detList = NULL;	/* List of all detached proceses. */
TCL_DECLARE_MUTEX(pipeMutex)		/* Guard access to detList. */

/*
 * Declarations for local procedures defined in this file:
 */

static TclFile	FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp,
	            CONST char *spec, int atOk, CONST char *arg, 
		    CONST char *nextArg, int flags, int *skipPtr,
		    int *closePtr, int *releasePtr));

/*
 *----------------------------------------------------------------------
 *
 * FileForRedirect --
 *
 *	This procedure does much of the work of parsing redirection
 *	operators.  It handles "@" if specified and allowed, and a file
 *	name, and opens the file if necessary.
 *
 * Results:
 *	The return value is the descriptor number for the file.  If an
 *	error occurs then NULL is returned and an error message is left
 *	in the interp's result.  Several arguments are side-effected; see
 *	the argument list below for details.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static TclFile
FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr,
	releasePtr)
    Tcl_Interp *interp;		/* Intepreter to use for error reporting. */
    CONST char *spec;			/* Points to character just after
				 * redirection character. */
    CONST char *arg;		/* Pointer to entire argument containing 
				 * spec:  used for error reporting. */
    int atOK;			/* Non-zero means that '@' notation can be 
				 * used to specify a channel, zero means that
				 * it isn't. */
    CONST char *nextArg;	/* Next argument in argc/argv array, if needed 
				 * for file name or channel name.  May be 
				 * NULL. */
    int flags;			/* Flags to use for opening file or to 
				 * specify mode for channel. */
    int *skipPtr;		/* Filled with 1 if redirection target was
				 * in spec, 2 if it was in nextArg. */
    int *closePtr;		/* Filled with one if the caller should 
				 * close the file when done with it, zero
				 * otherwise. */
    int *releasePtr;
{
    int writing = (flags & O_WRONLY);
    Tcl_Channel chan;
    TclFile file;

    *skipPtr = 1;
    if ((atOK != 0)  && (*spec == '@')) {
	spec++;
	if (*spec == '\0') {
	    spec = nextArg;
	    if (spec == NULL) {
		goto badLastArg;
	    }
	    *skipPtr = 2;
	}
        chan = Tcl_GetChannel(interp, spec, NULL);
        if (chan == (Tcl_Channel) NULL) {
            return NULL;
        }
	file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE);
        if (file == NULL) {
            Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
                    "\" wasn't opened for ",
                    ((writing) ? "writing" : "reading"), (char *) NULL);
            return NULL;
        }
	*releasePtr = 1;
	if (writing) {

	    /*
	     * Be sure to flush output to the file, so that anything
	     * written by the child appears after stuff we've already
	     * written.
	     */

            Tcl_Flush(chan);
	}
    } else {
	CONST char *name;
	Tcl_DString nameString;

	if (*spec == '\0') {
	    spec = nextArg;
	    if (spec == NULL) {
		goto badLastArg;
	    }
	    *skipPtr = 2;
	}
	name = Tcl_TranslateFileName(interp, spec, &nameString);
	if (name != NULL) {
	    file = TclpOpenFile(name, flags);
	} else {
	    file = NULL;
	}
	Tcl_DStringFree(&nameString);
	if (file == NULL) {
	    Tcl_AppendResult(interp, "couldn't ",
		    ((writing) ? "write" : "read"), " file \"", spec, "\": ",
		    Tcl_PosixError(interp), (char *) NULL);
	    return NULL;
	}
        *closePtr = 1;
    }
    return file;

    badLastArg:
    Tcl_AppendResult(interp, "can't specify \"", arg,
	    "\" as last word in command", (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DetachPids --
 *
 *	This procedure is called to indicate that one or more child
 *	processes have been placed in background and will never be
 *	waited for;  they should eventually be reaped by
 *	Tcl_ReapDetachedProcs.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DetachPids(numPids, pidPtr)
    int numPids;		/* Number of pids to detach:  gives size
				 * of array pointed to by pidPtr. */
    Tcl_Pid *pidPtr;		/* Array of pids to detach. */
{
    register Detached *detPtr;
    int i;

    Tcl_MutexLock(&pipeMutex);
    for (i = 0; i < numPids; i++) {
	detPtr = (Detached *) ckalloc(sizeof(Detached));
	detPtr->pid = pidPtr[i];
	detPtr->nextPtr = detList;
	detList = detPtr;
    }
    Tcl_MutexUnlock(&pipeMutex);

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReapDetachedProcs --
 *
 *	This procedure checks to see if any detached processes have
 *	exited and, if so, it "reaps" them by officially waiting on
 *	them.  It should be called "occasionally" to make sure that
 *	all detached processes are eventually reaped.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Processes are waited on, so that they can be reaped by the
 *	system.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ReapDetachedProcs()
{
    register Detached *detPtr;
    Detached *nextPtr, *prevPtr;
    int status;
    Tcl_Pid pid;

    Tcl_MutexLock(&pipeMutex);
    for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
	pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
	if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
	    prevPtr = detPtr;
	    detPtr = detPtr->nextPtr;
	    continue;
	}
	nextPtr = detPtr->nextPtr;
	if (prevPtr == NULL) {
	    detList = detPtr->nextPtr;
	} else {
	    prevPtr->nextPtr = detPtr->nextPtr;
	}
	ckfree((char *) detPtr);
	detPtr = nextPtr;
    }
    Tcl_MutexUnlock(&pipeMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCleanupChildren --
 *
 *	This is a utility procedure used to wait for child processes
 *	to exit, record information about abnormal exits, and then
 *	collect any stderr output generated by them.
 *
 * Results:
 *	The return value is a standard Tcl result.  If anything at
 *	weird happened with the child processes, TCL_ERROR is returned
 *	and a message is left in the interp's result.
 *
 * Side effects:
 *	If the last character of the interp's result is a newline, then it
 *	is removed unless keepNewline is non-zero.  File errorId gets
 *	closed, and pidPtr is freed back to the storage allocator.
 *
 *----------------------------------------------------------------------
 */

int
TclCleanupChildren(interp, numPids, pidPtr, errorChan)
    Tcl_Interp *interp;		/* Used for error messages. */
    int numPids;		/* Number of entries in pidPtr array. */
    Tcl_Pid *pidPtr;		/* Array of process ids of children. */
    Tcl_Channel errorChan;	/* Channel for file containing stderr output
				 * from pipeline.  NULL means there isn't any
				 * stderr output. */
{
    int result = TCL_OK;
    int i, abnormalExit, anyErrorInfo;
    Tcl_Pid pid;
    WAIT_STATUS_TYPE waitStatus;
    CONST char *msg;
    unsigned long resolvedPid;

    abnormalExit = 0;
    for (i = 0; i < numPids; i++) {
	/*
	 * We need to get the resolved pid before we wait on it as
	 * the windows implimentation of Tcl_WaitPid deletes the
	 * information such that any following calls to TclpGetPid
	 * fail.
	 */
	resolvedPid = TclpGetPid(pidPtr[i]);
        pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0);
	if (pid == (Tcl_Pid) -1) {
	    result = TCL_ERROR;
            if (interp != (Tcl_Interp *) NULL) {
                msg = Tcl_PosixError(interp);
                if (errno == ECHILD) {
		    /*
                     * This changeup in message suggested by Mark Diekhans
                     * to remind people that ECHILD errors can occur on
                     * some systems if SIGCHLD isn't in its default state.
                     */

                    msg =
                        "child process lost (is SIGCHLD ignored or trapped?)";
                }
                Tcl_AppendResult(interp, "error waiting for process to exit: ",
                        msg, (char *) NULL);
            }
	    continue;
	}

	/*
	 * Create error messages for unusual process exits.  An
	 * extra newline gets appended to each error message, but
	 * it gets removed below (in the same fashion that an
	 * extra newline in the command's output is removed).
	 */

	if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
	    char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];

	    result = TCL_ERROR;
	    TclFormatInt(msg1, (long) resolvedPid);
	    if (WIFEXITED(waitStatus)) {
                if (interp != (Tcl_Interp *) NULL) {
		    TclFormatInt(msg2, WEXITSTATUS(waitStatus));
                    Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
                            (char *) NULL);
                }
		abnormalExit = 1;
	    } else if (WIFSIGNALED(waitStatus)) {
                if (interp != (Tcl_Interp *) NULL) {
                    CONST char *p;
                    
                    p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
                    Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
                            Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
                            (char *) NULL);
                    Tcl_AppendResult(interp, "child killed: ", p, "\n",
                            (char *) NULL);
                }
	    } else if (WIFSTOPPED(waitStatus)) {
                if (interp != (Tcl_Interp *) NULL) {
                    CONST char *p;

                    p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
                    Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
                            Tcl_SignalId((int) (WSTOPSIG(waitStatus))),
                            p, (char *) NULL);
                    Tcl_AppendResult(interp, "child suspended: ", p, "\n",
                            (char *) NULL);
                }
	    } else {
                if (interp != (Tcl_Interp *) NULL) {