tclevent.c

tcl是工具命令语言

/* 
 * tclEvent.c --
 *
 *	This file implements some general event related interfaces including
 *	background errors, exit handlers, and the "vwait" and "update"
 *	command procedures. 
 *
 * Copyright (c) 1990-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 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: tclEvent.c,v 1.28 2003/02/22 09:23:16 vasiljevic Exp $
 */

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

/*
 * The data structure below is used to report background errors.  One
 * such structure is allocated for each error;  it holds information
 * about the interpreter and the error until bgerror can be invoked
 * later as an idle handler.
 */

typedef struct BgError {
    Tcl_Interp *interp;		/* Interpreter in which error occurred.  NULL
				 * means this error report has been cancelled
				 * (a previous report generated a break). */
    char *errorMsg;		/* Copy of the error message (the interp's
				 * result when the error occurred).
				 * Malloc-ed. */
    char *errorInfo;		/* Value of the errorInfo variable
				 * (malloc-ed). */
    char *errorCode;		/* Value of the errorCode variable
				 * (malloc-ed). */
    struct BgError *nextPtr;	/* Next in list of all pending error
				 * reports for this interpreter, or NULL
				 * for end of list. */
} BgError;

/*
 * One of the structures below is associated with the "tclBgError"
 * assoc data for each interpreter.  It keeps track of the head and
 * tail of the list of pending background errors for the interpreter.
 */

typedef struct ErrAssocData {
    BgError *firstBgPtr;	/* First in list of all background errors
				 * waiting to be processed for this
				 * interpreter (NULL if none). */
    BgError *lastBgPtr;		/* Last in list of all background errors
				 * waiting to be processed for this
				 * interpreter (NULL if none). */
} ErrAssocData;

/*
 * For each exit handler created with a call to Tcl_CreateExitHandler
 * there is a structure of the following type:
 */

typedef struct ExitHandler {
    Tcl_ExitProc *proc;		/* Procedure to call when process exits. */
    ClientData clientData;	/* One word of information to pass to proc. */
    struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
				 * this application, or NULL for end of list. */
} ExitHandler;

/*
 * There is both per-process and per-thread exit handlers.
 * The first list is controlled by a mutex.  The other is in
 * thread local storage.
 */

static ExitHandler *firstExitPtr = NULL;
				/* First in list of all exit handlers for
				 * application. */
TCL_DECLARE_MUTEX(exitMutex)

/*
 * This variable is set to 1 when Tcl_Finalize is called, and at the end of
 * its work, it is reset to 0. The variable is checked by TclInExit() to
 * allow different behavior for exit-time processing, e.g. in closing of
 * files and pipes.
 */

static int inFinalize = 0;
static int subsystemsInitialized = 0;

typedef struct ThreadSpecificData {
    ExitHandler *firstExitPtr;  /* First in list of all exit handlers for
				 * this thread. */
    int inExit;			/* True when this thread is exiting. This
				 * is used as a hack to decide to close
				 * the standard channels. */
    Tcl_Obj *tclLibraryPath;	/* Path(s) to the Tcl library */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

/*
 * Common string for the library path for sharing across threads.
 */
char *tclLibraryPathStr;

/*
 * Prototypes for procedures referenced only in this file:
 */

static void		BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static void		HandleBgErrors _ANSI_ARGS_((ClientData clientData));
static char *		VwaitVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
			    CONST char *name2, int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BackgroundError --
 *
 *	This procedure is invoked to handle errors that occur in Tcl
 *	commands that are invoked in "background" (e.g. from event or
 *	timer bindings).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The command "bgerror" is invoked later as an idle handler to
 *	process the error, passing it the error message.  If that fails,
 *	then an error message is output on stderr.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_BackgroundError(interp)
    Tcl_Interp *interp;		/* Interpreter in which an error has
				 * occurred. */
{
    BgError *errPtr;
    CONST char *errResult, *varValue;
    ErrAssocData *assocPtr;
    int length;

    /*
     * The Tcl_AddErrorInfo call below (with an empty string) ensures that
     * errorInfo gets properly set.  It's needed in cases where the error
     * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
     * in these cases errorInfo still won't have been set when this
     * procedure is called.
     */

    Tcl_AddErrorInfo(interp, "");

    errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
	
    errPtr = (BgError *) ckalloc(sizeof(BgError));
    errPtr->interp = interp;
    errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
    memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
    varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
    if (varValue == NULL) {
	varValue = errPtr->errorMsg;
    }
    errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
    strcpy(errPtr->errorInfo, varValue);
    varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
    if (varValue == NULL) {
	varValue = "";
    }
    errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
    strcpy(errPtr->errorCode, varValue);
    errPtr->nextPtr = NULL;

    assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
	    (Tcl_InterpDeleteProc **) NULL);
    if (assocPtr == NULL) {

	/*
	 * This is the first time a background error has occurred in
	 * this interpreter.  Create associated data to keep track of
	 * pending error reports.
	 */

	assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
	assocPtr->firstBgPtr = NULL;
	assocPtr->lastBgPtr = NULL;
	Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
		(ClientData) assocPtr);
    }
    if (assocPtr->firstBgPtr == NULL) {
	assocPtr->firstBgPtr = errPtr;
	Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
    } else {
	assocPtr->lastBgPtr->nextPtr = errPtr;
    }
    assocPtr->lastBgPtr = errPtr;
    Tcl_ResetResult(interp);
}

/*
 *----------------------------------------------------------------------
 *
 * HandleBgErrors --
 *
 *	This procedure is invoked as an idle handler to process all of
 *	the accumulated background errors.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on what actions "bgerror" takes for the errors.
 *
 *----------------------------------------------------------------------
 */

static void
HandleBgErrors(clientData)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
{
    Tcl_Interp *interp;
    CONST char *argv[2];
    int code;
    BgError *errPtr;
    ErrAssocData *assocPtr = (ErrAssocData *) clientData;
    Tcl_Channel errChannel;

    Tcl_Preserve((ClientData) assocPtr);
    
    while (assocPtr->firstBgPtr != NULL) {
	interp = assocPtr->firstBgPtr->interp;
	if (interp == NULL) {
	    goto doneWithInterp;
	}

	/*
	 * Restore important state variables to what they were at
	 * the time the error occurred.
	 */

	Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
		TCL_GLOBAL_ONLY);
	Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
		TCL_GLOBAL_ONLY);

	/*
	 * Create and invoke the bgerror command.
	 */

	argv[0] = "bgerror";
	argv[1] = assocPtr->firstBgPtr->errorMsg;
	
	Tcl_AllowExceptions(interp);
        Tcl_Preserve((ClientData) interp);
	code = TclGlobalInvoke(interp, 2, argv, 0);
	if (code == TCL_ERROR) {

            /*
             * If the interpreter is safe, we look for a hidden command
             * named "bgerror" and call that with the error information.
             * Otherwise, simply ignore the error. The rationale is that
             * this could be an error caused by a malicious applet trying
             * to cause an infinite barrage of error messages. The hidden
             * "bgerror" command can be used by a security policy to
             * interpose on such attacks and e.g. kill the applet after a
             * few attempts.
             */

            if (Tcl_IsSafe(interp)) {
		Tcl_SavedResult save;
		
		Tcl_SaveResult(interp, &save);
                TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
		Tcl_RestoreResult(interp, &save);

                goto doneWithInterp;
            } 

            /*
             * We have to get the error output channel at the latest possible
             * time, because the eval (above) might have changed the channel.
             */
            
            errChannel = Tcl_GetStdChannel(TCL_STDERR);
            if (errChannel != (Tcl_Channel) NULL) {
		char *string;
		int len;

		string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
		if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) {
                    Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
                    Tcl_WriteChars(errChannel, "\n", -1);
                } else {
                    Tcl_WriteChars(errChannel,
                            "bgerror failed to handle background error.\n",
                            -1);
                    Tcl_WriteChars(errChannel, "    Original error: ", -1);
                    Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
                            -1);
                    Tcl_WriteChars(errChannel, "\n", -1);
                    Tcl_WriteChars(errChannel, "    Error in bgerror: ", -1);
                    Tcl_WriteChars(errChannel, string, len);
                    Tcl_WriteChars(errChannel, "\n", -1);
                }
                Tcl_Flush(errChannel);
            }
	} else if (code == TCL_BREAK) {

	    /*
	     * Break means cancel any remaining error reports for this
	     * interpreter.
	     */

	    for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
		    errPtr = errPtr->nextPtr) {
		if (errPtr->interp == interp) {
		    errPtr->interp = NULL;
		}
	    }
	}

	/*
	 * Discard the command and the information about the error report.
	 */

doneWithInterp:

	if (assocPtr->firstBgPtr) {
	    ckfree(assocPtr->firstBgPtr->errorMsg);
	    ckfree(assocPtr->firstBgPtr->errorInfo);
	    ckfree(assocPtr->firstBgPtr->errorCode);
	    errPtr = assocPtr->firstBgPtr->nextPtr;
	    ckfree((char *) assocPtr->firstBgPtr);
	    assocPtr->firstBgPtr = errPtr;
	}
        
        if (interp != NULL) {
            Tcl_Release((ClientData) interp);
        }
    }
    assocPtr->lastBgPtr = NULL;

    Tcl_Release((ClientData) assocPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * BgErrorDeleteProc --
 *
 *	This procedure is associated with the "tclBgError" assoc data
 *	for an interpreter;  it is invoked when the interpreter is
 *	deleted in order to free the information assoicated with any
 *	pending error reports.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Background error information is freed: if there were any
 *	pending error reports, they are cancelled.
 *
 *----------------------------------------------------------------------
 */

static void
BgErrorDeleteProc(clientData, interp)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
    Tcl_Interp *interp;		/* Interpreter being deleted. */
{
    ErrAssocData *assocPtr = (ErrAssocData *) clientData;
    BgError *errPtr;

    while (assocPtr->firstBgPtr != NULL) {
	errPtr = assocPtr->firstBgPtr;
	assocPtr->firstBgPtr = errPtr->nextPtr;