diff options
Diffstat (limited to 'tcl/generic/tclEvent.c')
| -rw-r--r-- | tcl/generic/tclEvent.c | 698 |
1 files changed, 698 insertions, 0 deletions
diff --git a/tcl/generic/tclEvent.c b/tcl/generic/tclEvent.c new file mode 100644 index 00000000000..554878884a3 --- /dev/null +++ b/tcl/generic/tclEvent.c @@ -0,0 +1,698 @@ +/* + * 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. + * + * RCS: @(#) $Id$ + */ + +#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(); + TclpFinalize(); + 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; +} |