737 lines
20 KiB
C
737 lines
20 KiB
C
/*
|
||
* 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"
|
||
|
||
#ifdef BGLK_CODE
|
||
# define STk_tcl_getvar SCM_tcl_getvar
|
||
#endif
|
||
|
||
/*
|
||
* 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;
|
||
|
||
#ifndef SCM_CODE
|
||
/*
|
||
* 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;
|
||
#endif
|
||
|
||
/*
|
||
* 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));
|
||
#ifndef SCM_CODE
|
||
static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
|
||
Tcl_Interp *interp, char *name1, char *name2,
|
||
int flags));
|
||
#endif
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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);
|
||
#ifdef SCM_CODE
|
||
varValue = (char *) STk_tcl_getvar("*error-info*", "#f");
|
||
#else
|
||
varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
|
||
#endif
|
||
if (varValue == NULL) {
|
||
varValue = errPtr->errorMsg;
|
||
}
|
||
errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
|
||
strcpy(errPtr->errorInfo, varValue);
|
||
#ifdef SCM_CODE
|
||
varValue = Tcl_GetVar(interp, "*error-code*", TCL_GLOBAL_ONLY);
|
||
#else
|
||
varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
|
||
#endif
|
||
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;
|
||
#ifndef SCM_CODE
|
||
Tcl_Channel errChannel;
|
||
#endif
|
||
|
||
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.
|
||
*/
|
||
|
||
#ifdef SCM_CODE
|
||
Tcl_SetVar(interp, "*error-info*", assocPtr->firstBgPtr->errorInfo,
|
||
TCL_GLOBAL_ONLY);
|
||
Tcl_SetVar(interp, "*error-code*", assocPtr->firstBgPtr->errorCode,
|
||
TCL_GLOBAL_ONLY);
|
||
#else
|
||
Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
|
||
TCL_GLOBAL_ONLY);
|
||
Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
|
||
TCL_GLOBAL_ONLY);
|
||
#endif
|
||
|
||
/*
|
||
* Create and invoke the bgerror command.
|
||
*/
|
||
|
||
argv[0] = "bgerror";
|
||
#ifdef SCM_CODE
|
||
# ifdef STk_CODE
|
||
argv[1] = (char *) STk_stringify(assocPtr->firstBgPtr->errorMsg, 0);
|
||
# else
|
||
argv[1] = (char *) SCM_stringify(assocPtr->firstBgPtr->errorMsg, 0);
|
||
# endif
|
||
#else
|
||
argv[1] = assocPtr->firstBgPtr->errorMsg;
|
||
#endif
|
||
command = Tcl_Merge(2, argv);
|
||
Tcl_AllowExceptions(interp);
|
||
Tcl_Preserve((ClientData) interp);
|
||
code = Tcl_GlobalEval(interp, command);
|
||
ckfree(command);
|
||
#ifndef SCM_CODE
|
||
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;
|
||
}
|
||
}
|
||
}
|
||
#endif
|
||
/*
|
||
* 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. */
|
||
{
|
||
#ifndef SCM_CODE
|
||
Tcl_Finalize();
|
||
#endif
|
||
#ifdef TCL_MEM_DEBUG
|
||
if (tclMemDumpFileName != NULL) {
|
||
Tcl_DumpActiveMemory(tclMemDumpFileName);
|
||
}
|
||
#endif
|
||
TclPlatformExit(status);
|
||
}
|
||
|
||
#ifndef SCM_CODE
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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;
|
||
}
|
||
#endif
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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;
|
||
}
|