Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/C/Applications/Tcl-Tk 8.0/Pre-installed version/tcl8.0/generic/tclEvent.c

C/C++ Source or Header | 1997-08-15 | 19.5 KB | 698 lines | [TEXT/CWIE]

/*
 * 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-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tclEvent.c 1.153 97/08/11 20:22:31
 */

#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;        /* The error message (interp->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;

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

/*
 * The following variable is a "secret" indication to Tcl_Exit that
 * it should dump out the state of memory before exiting.  If the
 * value is non-NULL, it gives the name of the file in which to
 * dump memory usage information.
 */

char *tclMemDumpFileName = NULL;

/*
 * This variable is set to 1 when Tcl_Exit 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 tclInExit = 0;

/*
 * 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, char *name1, 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;
    char *errResult, *varValue;
    ErrAssocData *assocPtr;

    /*
     * 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 = TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL);

    errPtr = (BgError *) ckalloc(sizeof(BgError));
    errPtr->interp = interp;
    errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(errResult) + 1));
    strcpy(errPtr->errorMsg, errResult);
    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;
    char *command;
    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;
    command = Tcl_Merge(2, argv);
    Tcl_AllowExceptions(interp);
        Tcl_Preserve((ClientData) interp);
    code = Tcl_GlobalEval(interp, command);
    ckfree(command);
    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_HashTable *hTblPtr;
                Tcl_HashEntry *hPtr;

                hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
                        "tclHiddenCmds", NULL);
                if (hTblPtr == (Tcl_HashTable *) NULL) {
                    goto doneWithInterp;
                }
                hPtr = Tcl_FindHashEntry(hTblPtr, "bgerror");
                if (hPtr == (Tcl_HashEntry *) NULL) {
                    goto doneWithInterp;
                }

                /*
                 * OK, the hidden command "bgerror" exists, invoke it.
                 */

                argv[0] = "bgerror";
                argv[1] = ckalloc((unsigned)
                        strlen(assocPtr->firstBgPtr->errorMsg));
                strcpy(argv[1], assocPtr->firstBgPtr->errorMsg);
                (void) TclInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
                ckfree(argv[1]);

                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) {
                if (strcmp(interp->result,
           "\"bgerror\" is an invalid command name or ambiguous abbreviation")
                        == 0) {
                    Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
                    Tcl_Write(errChannel, "\n", -1);
                } else {
                    Tcl_Write(errChannel,
                            "bgerror failed to handle background error.\n",
                            -1);
                    Tcl_Write(errChannel, "    Original error: ", -1);
                    Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg,
                            -1);
                    Tcl_Write(errChannel, "\n", -1);
                    Tcl_Write(errChannel, "    Error in bgerror: ", -1);
                    Tcl_Write(errChannel, interp->result, -1);
                    Tcl_Write(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;
    ckfree(errPtr->errorMsg);
    ckfree(errPtr->errorInfo);
    ckfree(errPtr->errorCode);
    ckfree((char *) errPtr);
    }
    Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
    Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateExitHandler --
 *
 *    Arrange for a given procedure to be invoked just before the
 *    application exits.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Proc will be invoked with clientData as argument when the
 *    application exits.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_CreateExitHandler(proc, clientData)
    Tcl_ExitProc *proc;        /* Procedure to invoke. */
    ClientData clientData;    /* Arbitrary value to pass to proc. */
{
    ExitHandler *exitPtr;

    exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
    exitPtr->proc = proc;
    exitPtr->clientData = clientData;
    exitPtr->nextPtr = firstExitPtr;
    firstExitPtr = exitPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteExitHandler --
 *
 *    This procedure cancels an existing exit handler matching proc
 *    and clientData, if such a handler exits.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    If there is an exit handler corresponding to proc and clientData
 *    then it is cancelled;  if no such handler exists then nothing
 *    happens.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteExitHandler(proc, clientData)
    Tcl_ExitProc *proc;        /* Procedure that was previously registered. */
    ClientData clientData;    /* Arbitrary value to pass to proc. */
{
    ExitHandler *exitPtr, *prevPtr;

    for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
        prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
    if ((exitPtr->proc == proc)
        && (exitPtr->clientData == clientData)) {
        if (prevPtr == NULL) {
        firstExitPtr = exitPtr->nextPtr;
        } else {
        prevPtr->nextPtr = exitPtr->nextPtr;
        }
        ckfree((char *) exitPtr);
        return;
    }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Exit --
 *
 *    This procedure is called to terminate the application.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    All existing exit handlers are invoked, then the application
 *    ends.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Exit(status)
    int status;            /* Exit status for application;  typically
                 * 0 for normal return, 1 for error return. */
{
    Tcl_Finalize();
#ifdef TCL_MEM_DEBUG
    if (tclMemDumpFileName != NULL) {
    Tcl_DumpActiveMemory(tclMemDumpFileName);
    }
#endif
    TclPlatformExit(status);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Finalize --
 *
 *    Runs the exit handlers to allow Tcl to clean up its state prior
 *    to being unloaded. Called by Tcl_Exit and when Tcl was dynamically
 *    loaded and is now being unloaded.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Whatever the exit handlers do. Also frees up storage associated
 *    with the Tcl object type table.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Finalize()
{
    ExitHandler *exitPtr;

    /*
     * Invoke exit handler first.
     */

    tclInExit = 1;
    for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
    /*
     * Be careful to remove the handler from the list before invoking
     * its callback.  This protects us against double-freeing if the
     * callback should call Tcl_DeleteExitHandler on itself.
     */

    firstExitPtr = exitPtr->nextPtr;
    (*exitPtr->proc)(exitPtr->clientData);
    ckfree((char *) exitPtr);
    }

    /*
     * Now finalize the Tcl execution environment.  Note that this must be done
     * after the exit handlers, because there are order dependencies.
     */

    TclFinalizeCompExecEnv();
    TclFinalizeEnvironment();
    firstExitPtr = NULL;
    tclInExit = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInExit --
 *
 *    Determines if we are in the middle of exit-time cleanup.
 *
 * Results:
 *    If we are in the middle of exiting, 1, otherwise 0.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
TclInExit()
{
    return tclInExit;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_VwaitCmd --
 *
 *    This procedure is invoked to process the "vwait" 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_VwaitCmd(clientData, interp, argc, argv)
    ClientData clientData;    /* Not used. */
    Tcl_Interp *interp;        /* Current interpreter. */
    int argc;            /* Number of arguments. */
    char **argv;        /* Argument strings. */
{
    int done, foundEvent;

    if (argc != 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"",
        argv[0], " name\"", (char *) NULL);
    return TCL_ERROR;
    }
    if (Tcl_TraceVar(interp, argv[1],
        TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
        VwaitVarProc, (ClientData) &done) != TCL_OK) {
    return TCL_ERROR;
    };
    done = 0;
    foundEvent = 1;
    while (!done && foundEvent) {
    foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
    }
    Tcl_UntraceVar(interp, argv[1],
        TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
        VwaitVarProc, (ClientData) &done);

    /*
     * Clear out the interpreter's result, since it may have been set
     * by event handlers.
     */

    Tcl_ResetResult(interp);
    if (!foundEvent) {
    Tcl_AppendResult(interp, "can't wait for variable \"", argv[1],
        "\":  would wait forever", (char *) NULL);
    return TCL_ERROR;
    }
    return TCL_OK;
}

    /* ARGSUSED */
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;    /* Pointer to integer to set to 1. */
    Tcl_Interp *interp;        /* Interpreter containing variable. */
    char *name1;        /* Name of variable. */
    char *name2;        /* Second part of variable name. */
    int flags;            /* Information about what happened. */
{
    int *donePtr = (int *) clientData;

    *donePtr = 1;
    return (char *) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpdateCmd --
 *
 *    This procedure is invoked to process the "update" 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_UpdateCmd(clientData, interp, argc, argv)
    ClientData clientData;    /* Not used. */
    Tcl_Interp *interp;        /* Current interpreter. */
    int argc;            /* Number of arguments. */
    char **argv;        /* Argument strings. */
{
    int flags;

    if (argc == 1) {
    flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
    } else if (argc == 2) {
    if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) {
        Tcl_AppendResult(interp, "bad option \"", argv[1],
            "\": must be idletasks", (char *) NULL);
        return TCL_ERROR;
    }
    flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
    } else {
    Tcl_AppendResult(interp, "wrong # args: should be \"",
        argv[0], " ?idletasks?\"", (char *) NULL);
    return TCL_ERROR;
    }

    while (Tcl_DoOneEvent(flags) != 0) {
    /* Empty loop body */
    }

    /*
     * Must clear the interpreter's result because event handlers could
     * have executed commands.
     */

    Tcl_ResetResult(interp);
    return TCL_OK;
}