/*
* tclEvent.c --
*
* This file implements some general event related interfaces including
* background errors, exit handlers, and the "vwait" and "update" command
* functions.
*
* Copyright (c) 1990-1994 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 2004 by Zoran Vasiljevic.
*
* 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.80.2.2 2009/10/07 23:10:50 andreas_kupries Exp $
*/
#include "tclInt.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 an idle handler command can be invoked.
*/
typedef struct BgError {
Tcl_Obj *errorMsg; /* Copy of the error message (the interp's
* result when the error occurred). */
Tcl_Obj *returnOpts; /* Active return options when the error
* occurred */
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 {
Tcl_Interp *interp; /* Interpreter in which error occurred. */
Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */
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_Create(Late)ExitHandler there is
* a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function 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. */
static ExitHandler *firstLateExitPtr = NULL;
/* First in list of all late 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;
/*
* This variable contains the application wide exit handler. It will be
* called by Tcl_Exit instead of the C-runtime exit if this variable is set
* to a non-NULL value.
*/
static Tcl_ExitProc *appExitPtr = NULL;
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. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#ifdef TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
#endif /* TCL_THREADS */
/*
* Prototypes for functions referenced only in this file:
*/
static void BgErrorDeleteProc(ClientData clientData,
Tcl_Interp *interp);
static void HandleBgErrors(ClientData clientData);
static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp,
CONST char *name1, CONST char *name2, int flags);
/*
*----------------------------------------------------------------------
*
* Tcl_BackgroundError --
*
* This function 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:
* A handler command is invoked later as an idle handler to process the
* error, passing it the interp result and return options.
*
*----------------------------------------------------------------------
*/
void
Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
* occurred. */
{
TclBackgroundException(interp, TCL_ERROR);
}
void
TclBackgroundException(
Tcl_Interp *interp, /* Interpreter in which an exception has
* occurred. */
int code) /* The exception code value */
{
BgError *errPtr;
ErrAssocData *assocPtr;
if (code == TCL_OK) {
return;
}
errPtr = (BgError *) ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL);
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 function is invoked as an idle handler to process all of the
* accumulated background errors.
*
* Results:
* None.
*
* Side effects:
* Depends on what actions the handler command takes for the errors.
*
*----------------------------------------------------------------------
*/
static void
HandleBgErrors(
ClientData clientData) /* Pointer to ErrAssocData structure. */
{
ErrAssocData *assocPtr = (ErrAssocData *) clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
/*
* Not bothering to save/restore the interp state. Assume that any code
* that has interp state it needs to keep will make its own
* Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
* that could lead us here.
*/
Tcl_Preserve((ClientData) assocPtr);
Tcl_Preserve((ClientData) interp);
while (assocPtr->firstBgPtr != NULL) {
int code, prefixObjc;
Tcl_Obj **prefixObjv, **tempObjv;
/*
* Note we copy the handler command prefix each pass through, so
* we do support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
errPtr = assocPtr->firstBgPtr;
Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);
/*
* Discard the command and the information about the error report.
*/
Tcl_DecrRefCount(copyObj);
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
ckfree((char *) errPtr);
ckfree((char *) tempObjv);
if (code == TCL_BREAK) {
/*
* Break means cancel any remaining error reports for this
* interpreter.
*/
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
ckfree((char *) errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
Tcl_WriteChars(errChannel,
"error in background error handler:\n", -1);
if (valuePtr) {
Tcl_WriteObj(errChannel, valuePtr);
} else {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
}
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_Flush(errChannel);
}
}
}
assocPtr->lastBgPtr = NULL;
Tcl_Release((ClientData) interp);
Tcl_Release((ClientData) assocPtr);
}
/*
*----------------------------------------------------------------------
*
* TclDefaultBgErrorHandlerObjCmd --
*
* This function is invoked to process the "::tcl::Bgerror" Tcl command.
* It is the default handler command registered with [interp bgerror] for
* the sake of compatibility with older Tcl releases.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Depends on what actions the "bgerror" command takes for the errors.
*
*----------------------------------------------------------------------
*/
int
TclDefaultBgErrorHandlerObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
Tcl_Obj *keyPtr, *valuePtr;
Tcl_Obj *tempObjv[2];
int code, level;
Tcl_InterpState saved;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "msg options");
return TCL_ERROR;
}
/*
* Check for a valid return options dictionary.
*/
TclNewLiteralStringObj(keyPtr, "-level");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-level\"", -1));
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
return TCL_ERROR;
}
TclNewLiteralStringObj(keyPtr, "-code");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-code\"", -1));
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
return TCL_ERROR;
}
if (level != 0) {
/* We're handling a TCL_RETURN exception */
code = TCL_RETURN;
}
if (code == TCL_OK) {
/*
* Somehow we got to exception handling with no exception.
* (Pass TCL_OK to TclBackgroundException()?)
* Just return without doing anything.
*/
return TCL_OK;
}
/* Construct the bgerror command */
TclNewLiteralStringObj(tempObjv[0], "bgerror");
Tcl_IncrRefCount(tempObjv[0]);
/*
* Determine error message argument. Check the return options in case
* a non-error exception brought us here.
*/
switch (code) {
case TCL_ERROR:
tempObjv[1] = objv[1];
break;
case TCL_BREAK:
TclNewLiteralStringObj(tempObjv[1],
"invoked \"break\" outside of a loop");
break;
case TCL_CONTINUE:
TclNewLiteralStringObj(tempObjv[1],
"invoked \"continue\" outside of a loop");
break;
default:
tempObjv[1] = Tcl_ObjPrintf("command returned bad code: %d", code);
break;
}
Tcl_IncrRefCount(tempObjv[1]);
if (code != TCL_ERROR) {
Tcl_SetObjResult(interp, tempObjv[1]);
}
TclNewLiteralStringObj(keyPtr, "-errorcode");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_SetObjErrorCode(interp, valuePtr);
}
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_AppendObjToErrorInfo(interp, valuePtr);
}
if (code == TCL_ERROR) {
Tcl_SetObjResult(interp, tempObjv[1]);
}
/*
* Save interpreter state so we can restore it if multiple handler
* attempts are needed.
*/
saved = Tcl_SaveInterpState(interp, code);
/* Invoke the bgerror command. */
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
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_RestoreInterpState(interp, saved);
TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
} else {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
if (Tcl_FindCommand(interp, "bgerror", NULL,
TCL_GLOBAL_ONLY) == NULL) {
Tcl_RestoreInterpState(interp, saved);
Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp,
"errorInfo", NULL, TCL_GLOBAL_ONLY));
Tcl_WriteChars(errChannel, "\n", -1);
} else {
Tcl_DiscardInterpState(saved);
Tcl_WriteChars(errChannel,
"bgerror failed to handle background error.\n",-1);
Tcl_WriteChars(errChannel, " Original error: ", -1);
Tcl_WriteObj(errChannel, tempObjv[1]);
Tcl_WriteChars(errChannel, "\n", -1);
Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
Tcl_WriteObj(errChannel, resultPtr);
Tcl_WriteChars(errChannel, "\n", -1);
}
Tcl_DecrRefCount(resultPtr);
Tcl_Flush(errChannel);
} else {
Tcl_DiscardInterpState(saved);
}
}
code = TCL_OK;
} else {
Tcl_DiscardInterpState(saved);
}
Tcl_DecrRefCount(tempObjv[0]);
Tcl_DecrRefCount(tempObjv[1]);
Tcl_ResetResult(interp);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclSetBgErrorHandler --
*
* This function sets the command prefix to be used to handle background
* errors in interp.
*
* Results:
* None.
*
* Side effects:
* Error handler is registered.
*
*----------------------------------------------------------------------
*/
void
TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
ErrAssocData *assocPtr = (ErrAssocData *)
Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
}
if (assocPtr == NULL) {
/*
* First access: initialize.
*/
assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
(ClientData) assocPtr);
}
if (assocPtr->cmdPrefix) {
Tcl_DecrRefCount(assocPtr->cmdPrefix);
}
assocPtr->cmdPrefix = cmdPrefix;
Tcl_IncrRefCount(assocPtr->cmdPrefix);
}
/*
*----------------------------------------------------------------------
*
* TclGetBgErrorHandler --
*
* This function retrieves the command prefix currently used to handle
* background errors in interp.
*
* Results:
* A (Tcl_Obj *) to a list of words (command prefix).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
ErrAssocData *assocPtr = (ErrAssocData *)
Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
Tcl_Obj *bgerrorObj;
TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
TclSetBgErrorHandler(interp, bgerrorObj);
assocPtr = (ErrAssocData *)
Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
/*
*----------------------------------------------------------------------
*
* BgErrorDeleteProc --
*
* This function 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 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;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
ckfree((char *) errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
Tcl_DecrRefCount(assocPtr->cmdPrefix);
Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateExitHandler --
*
* Arrange for a given function 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(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* TclCreateLateExitHandler --
*
* Arrange for a given function to be invoked after all pre-thread cleanups
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the application
* exits.
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstLateExitPtr;
firstLateExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteExitHandler --
*
* This function 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(
Tcl_ExitProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
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);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
/*
*----------------------------------------------------------------------
*
* TclDeleteLateExitHandler --
*
* This function cancels an existing late exit handler matching proc and
* clientData, if such a handler exits.
*
* Results:
* None.
*
* Side effects:
* If there is a late exit handler corresponding to proc and clientData then
* it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstLateExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree((char *) exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThreadExitHandler --
*
* Arrange for a given function to be invoked just before the current
* thread exits.
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the application
* exits.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
tsdPtr->firstExitPtr = exitPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteThreadExitHandler --
*
* This function 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_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
tsdPtr->firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree((char *) exitPtr);
return;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetExitProc --
*
* This function sets the application wide exit handler that will be
* called by Tcl_Exit in place of the C-runtime exit. If the application
* wide exit handler is NULL, the C-runtime exit will be used instead.
*
* Results:
* The previously set application wide exit handler.
*
* Side effects:
* Sets the application wide exit handler to the specified value.
*
*----------------------------------------------------------------------
*/
Tcl_ExitProc *
Tcl_SetExitProc(
Tcl_ExitProc *proc) /* New exit handler for app or NULL */
{
Tcl_ExitProc *prevExitProc;
/*
* Swap the old exit proc for the new one, saving the old one for our
* return value.
*/
Tcl_MutexLock(&exitMutex);
prevExitProc = appExitPtr;
appExitPtr = proc;
Tcl_MutexUnlock(&exitMutex);
return prevExitProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Exit --
*
* This function is called to terminate the application.
*
* Results:
* None.
*
* Side effects:
* All existing exit handlers are invoked, then the application ends.
*
*----------------------------------------------------------------------
*/
void
Tcl_Exit(
int status) /* Exit status for application; typically 0
* for normal return, 1 for error return. */
{
Tcl_ExitProc *currentAppExitPtr;
Tcl_MutexLock(&exitMutex);
currentAppExitPtr = appExitPtr;
Tcl_MutexUnlock(&exitMutex);
if (currentAppExitPtr) {
/*
* Warning: this code SHOULD NOT return, as there is code that depends
* on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone
* returns, so critical is this dependcy.
*/
currentAppExitPtr((ClientData) INT2PTR(status));
Tcl_Panic("AppExitProc returned unexpectedly");
} else {
/*
* Use default handling.
*/
Tcl_Finalize();
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
}
/*
*-------------------------------------------------------------------------
*
* TclInitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the first
* time an interp is created, or before any of the subsystems are used.
* This function ensures an order for the initialization of subsystems:
*
* 1. that cannot be initialized in lazy order because they are mutually
* dependent.
*
* 2. so that they can be finalized in a known order w/o causing the
* subsequent re-initialization of a subsystem in the act of shutting
* down another.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective initialization routines.
*
*-------------------------------------------------------------------------
*/
void
TclInitSubsystems(void)
{
if (inFinalize != 0) {
Tcl_Panic("TclInitSubsystems called while finalizing");
}
if (subsystemsInitialized == 0) {
/*
* Double check inside the mutex. There are definitly calls back into
* this routine from some of the functions below.
*/
TclpInitLock();
if (subsystemsInitialized == 0) {
/*
* Have to set this bit here to avoid deadlock with the routines
* below us that call into TclInitSubsystems.
*/
subsystemsInitialized = 1;
/*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
*/
TclInitThreadStorage(); /* Creates master hash table for
* thread local storage */
#if USE_TCLALLOC
TclInitAlloc(); /* Process wide mutex init */
#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* Process wide mutex init */
#endif
TclpInitPlatform(); /* Creates signal handler(s) */
TclInitDoubleConversion(); /* Initializes constants for
* converting to/from double. */
TclInitObjSubsystem(); /* Register obj types, create
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclpSetInterfaces();
TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
}
TclpInitUnlock();
}
TclInitNotifier();
}
/*
*----------------------------------------------------------------------
*
* Tcl_Finalize --
*
* Shut down Tcl. First calls registered exit handlers, then carefully
* shuts down various subsystems. Called by Tcl_Exit or when the Tcl
* shared library is being unloaded.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
void
Tcl_Finalize(void)
{
ExitHandler *exitPtr;
/*
* Invoke exit handlers first.
*/
Tcl_MutexLock(&exitMutex);
inFinalize = 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;
Tcl_MutexUnlock(&exitMutex);
(*exitPtr->proc)(exitPtr->clientData);
ckfree((char *) exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
TclpInitLock();
if (subsystemsInitialized == 0) {
goto alreadyFinalized;
}
subsystemsInitialized = 0;
/*
* Ensure the thread-specific data is initialised as it is used in
* Tcl_FinalizeThread()
*/
(void) TCL_TSD_INIT(&dataKey);
/*
* Clean up after the current thread now, after exit handlers. In
* particular, the testexithandler command sets up something that writes
* to standard output, which gets closed. Note that there is no
* thread-local storage or IO subsystem after this call.
*/
Tcl_FinalizeThread();
/*
* Now invoke late (process-wide) exit handlers.
*/
Tcl_MutexLock(&exitMutex);
for (exitPtr = firstLateExitPtr; exitPtr != NULL; exitPtr = firstLateExitPtr) {
/*
* 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_DeleteLateExitHandler on itself.
*/
firstLateExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
ckfree((char *) exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstLateExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
/*
* Now finalize the Tcl execution environment. Note that this must be done
* after the exit handlers, because there are order dependencies.
*/
TclFinalizeExecution();
TclFinalizeEnvironment();
/*
* Finalizing the filesystem must come after anything which might
* conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
* Undo all Tcl_ObjType registrations, and reset the master list of free
* Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or
* freed.
*
* Note in particular that TclFinalizeObjects() must follow
* TclFinalizeFilesystem() because TclFinalizeFilesystem free's the
* Tcl_Obj that holds the path of the current working directory.
*/
TclFinalizeObjects();
/*
* We must be sure the encoding finalization doesn't need to examine the
* filesystem in any way. Since it only needs to clean up internal data
* structures, this is fine.
*/
TclFinalizeEncodingSubsystem();
Tcl_SetPanicProc(NULL);
/*
* Repeat finalization of the thread local storage once more. Although
* this step is already done by the Tcl_FinalizeThread call above, series
* of events happening afterwards may re-initialize TSD slots. Those need
* to be finalized again, otherwise we're leaking memory chunks. Very
* important to note is that things happening afterwards should not
* reference anything which may re-initialize TSD's. This includes freeing
* Tcl_Objs's, among other things.
*
* This fixes the Tcl Bug #990552.
*/
TclFinalizeThreadData();
/*
* Now we can free constants for conversions to/from double.
*/
TclFinalizeDoubleConversion();
/*
* There have been several bugs in the past that cause exit handlers to be
* established during Tcl_Finalize processing. Such exit handlers leave
* malloc'ed memory, and Tcl_FinalizeThreadAlloc or
* Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The result
* can be a mysterious crash on process exit. Check here that nobody's
* done this.
*/
if (firstExitPtr != NULL) {
Tcl_Panic("exit handlers were created during Tcl_Finalize");
}
TclFinalizePreserve();
/*
* Free synchronization objects. There really should only be one thread
* alive at this moment.
*/
TclFinalizeSynchronization();
/*
* Close down the thread-specific object allocator.
*/
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
TclFinalizeThreadAlloc();
#endif
/*
* We defer unloading of packages until very late to avoid memory access
* issues. Both exit callbacks and synchronization variables may be stored
* in packages.
*
* Note that TclFinalizeLoad unloads packages in the reverse of the order
* they were loaded in (i.e. last to be loaded is the first to be
* unloaded). This can be important for correct unloading when
* dependencies exist.
*
* Once load has been finalized, we will have deleted any temporary copies
* of shared libraries and can therefore reset the filesystem to its
* original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
* At this point, there should no longer be any ckalloc'ed memory.
*/
TclFinalizeMemorySubsystem();
inFinalize = 0;
alreadyFinalized:
TclFinalizeLock();
}
/*
*----------------------------------------------------------------------
*
* Tcl_FinalizeThread --
*
* Runs the exit handlers to allow Tcl to clean up its state about a
* particular thread.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeThread(void)
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr;
/*
* We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because
* we don't want to initialize the data block if it hasn't been
* initialized already.
*/
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
exitPtr = tsdPtr->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_DeleteThreadExitHandler on itself.
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
(*exitPtr->proc)(exitPtr->clientData);
ckfree((char *) exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
TclFinalizeThreadObjects();
}
/*
* Blow away all thread local storage blocks.
*
* Note that Tcl API allows creation of threads which do not use any Tcl
* interp or other Tcl subsytems. Those threads might, however, use thread
* local storage, so we must unconditionally finalize it.
*
* Fix [Bug #571002]
*/
TclFinalizeThreadData();
}
/*
*----------------------------------------------------------------------
*
* 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(void)
{
return inFinalize;
}
/*
*----------------------------------------------------------------------
*
* TclInThreadExit --
*
* Determines if we are in the middle of thread exit-time cleanup.
*
* Results:
* If we are in the middle of exiting this thread, 1, otherwise 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclInThreadExit(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
return 0;
} else {
return tsdPtr->inExit;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_VwaitObjCmd --
*
* This function 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_VwaitObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
int done, foundEvent;
char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
nameString = Tcl_GetString(objv[1]);
if (Tcl_TraceVar(interp, nameString,
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);
if (Tcl_LimitExceeded(interp)) {
break;
}
}
Tcl_UntraceVar(interp, nameString,
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 \"", nameString,
"\": would wait forever", NULL);
return TCL_ERROR;
}
if (!done) {
Tcl_AppendResult(interp, "limit exceeded", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/* ARGSUSED */
static char *
VwaitVarProc(
ClientData clientData, /* Pointer to integer to set to 1. */
Tcl_Interp *interp, /* Interpreter containing variable. */
CONST char *name1, /* Name of variable. */
CONST char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
int *donePtr = (int *) clientData;
*donePtr = 1;
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpdateObjCmd --
*
* This function 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_UpdateObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
static CONST char *updateOptions[] = {"idletasks", NULL};
enum updateOptions {REGEXP_IDLETASKS};
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
} else if (objc == 2) {
if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
case REGEXP_IDLETASKS:
flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
}
} else {
Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
return TCL_ERROR;
}
while (Tcl_DoOneEvent(flags) != 0) {
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "limit exceeded", NULL);
return TCL_ERROR;
}
}
/*
* Must clear the interpreter's result because event handlers could have
* executed commands.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
#ifdef TCL_THREADS
/*
*-----------------------------------------------------------------------------
*
* NewThreadProc --
*
* Bootstrap function of a new Tcl thread.
*
* Results:
* None.
*
* Side Effects:
* Initializes Tcl notifier for the current thread.
*
*-----------------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(
ClientData clientData)
{
ThreadClientData *cdPtr;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
cdPtr = (ThreadClientData *) clientData;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */
(*threadProc)(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThread --
*
* This function creates a new thread. This actually belongs to the
* tclThread.c file but since we use some private data structures local
* to this file, it is placed here.
*
* Results:
* TCL_OK if the thread could be created. The thread ID is returned in a
* parameter.
*
* Side effects:
* A new thread is created.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
int stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#ifdef TCL_THREADS
ThreadClientData *cdPtr;
cdPtr = (ThreadClientData *) ckalloc(sizeof(ThreadClientData));
cdPtr->proc = proc;
cdPtr->clientData = clientData;
return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr,
stackSize, flags);
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
