/*
* tclEvent.c --
*
* This file implements some general event related interfaces including
* background errors, exit handlers, and the "vwait" and "update"
* command procedures.
*
* Copyright (c) 1990-1994 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* 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.55 2004/12/04 21:19:18 dgp 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_CreateExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Procedure to call when process exits. */
ClientData clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
* this application, or NULL for end of list. */
} ExitHandler;
/*
* There is both per-process and per-thread exit handlers.
* The first list is controlled by a mutex. The other is in
* thread local storage.
*/
static ExitHandler *firstExitPtr = NULL;
/* First in list of all exit handlers for
* application. */
TCL_DECLARE_MUTEX(exitMutex)
/*
* This variable is set to 1 when Tcl_Finalize is called, and at the end of
* its work, it is reset to 0. The variable is checked by TclInExit() to
* allow different behavior for exit-time processing, e.g. in closing of
* files and pipes.
*/
static int inFinalize = 0;
static int subsystemsInitialized = 0;
/*
* 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 _ANSI_ARGS_((
ClientData clientData));
#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));
static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
/*
*----------------------------------------------------------------------
*
* Tcl_BackgroundError --
*
* This procedure is invoked to handle errors that occur in Tcl
* commands that are invoked in "background" (e.g. from event or
* timer bindings).
*
* Results:
* None.
*
* Side effects:
* 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(interp)
Tcl_Interp *interp; /* Interpreter in which an error has
* occurred. */
{
BgError *errPtr;
ErrAssocData *assocPtr;
errPtr = (BgError *) ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, TCL_ERROR);
Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
(Tcl_InterpDeleteProc **) 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 procedure 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 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;
errPtr = assocPtr->firstBgPtr;
Tcl_IncrRefCount(assocPtr->cmdPrefix);
Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix,
&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(assocPtr->cmdPrefix);
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
ckfree((char *) errPtr);
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 = Tcl_NewStringObj("-errorinfo", -1);
Tcl_Obj *valuePtr;
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 procedure 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(dummy, interp, objc, objv)
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;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "msg options");
return TCL_ERROR;
}
/*
* Restore important state variables to what they were at
* the time the error occurred.
*
* Need to set the variables, not the interp fields, because
* Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy
* anything we write to the interp fields.
*/
keyPtr = Tcl_NewStringObj("-errorcode", -1);
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
}
keyPtr = Tcl_NewStringObj("-errorinfo", -1);
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
}
/* Create and invoke the bgerror command. */
tempObjv[0] = Tcl_NewStringObj("bgerror", -1);
Tcl_IncrRefCount(tempObjv[0]);
tempObjv[1] = objv[1];
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_ResetResult(interp);
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) {
if (valuePtr) {
Tcl_WriteObj(errChannel, valuePtr);
Tcl_WriteChars(errChannel, "\n", -1);
}
} else {
Tcl_WriteChars(errChannel,
"bgerror failed to handle background error.\n", -1);
Tcl_WriteChars(errChannel, " Original error: ", -1);
Tcl_WriteObj(errChannel, objv[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);
}
}
code = TCL_OK;
}
Tcl_DecrRefCount(tempObjv[0]);
Tcl_ResetResult(interp);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclSetBgErrorHandler --
*
* This procedure sets the command prefix to be used to handle
* background errors in interp.
*
* Results:
* None.
*
* Side effects:
* Error handler is registered.
*
*----------------------------------------------------------------------
*/
void
TclSetBgErrorHandler(interp, cmdPrefix)
Tcl_Interp *interp;
Tcl_Obj *cmdPrefix;
{
ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
"tclBgError", (Tcl_InterpDeleteProc **) 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 procedure 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(interp)
Tcl_Interp *interp;
{
ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
"tclBgError", (Tcl_InterpDeleteProc **) NULL);
if (assocPtr == NULL) {
TclSetBgErrorHandler(interp, Tcl_NewStringObj("::tcl::Bgerror", -1));
assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
"tclBgError", (Tcl_InterpDeleteProc **) NULL);
}
return assocPtr->cmdPrefix;
}
/*
*----------------------------------------------------------------------
*
* 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;
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 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;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* 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;
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;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThreadExitHandler --
*
* Arrange for a given procedure 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(proc, clientData)
Tcl_ExitProc *proc; /* Procedure 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 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_DeleteThreadExitHandler(proc, clientData)
Tcl_ExitProc *proc; /* Procedure 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 procedure 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(proc)
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 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_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) 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()
{
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 procedures 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.
*/
#if USE_TCLALLOC
TclInitAlloc(); /* process wide mutex init */
#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* process wide mutex init */
#endif
TclpInitPlatform(); /* creates signal handler(s) */
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()
{
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) {
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 after this call.
*/
Tcl_FinalizeThread();
/*
* Now finalize the Tcl execution environment. Note that this
* must be done after the exit handlers, because there are
* order dependencies.
*/
TclFinalizeCompExecEnv();
TclFinalizeEnvironment();
/*
* Finalizing the filesystem must come after anything which
* might conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
* 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();
/*
* Free synchronization objects. There really should only be one
* thread alive at this moment.
*/
TclFinalizeSynchronization();
/*
* 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();
/*
* There shouldn't be any malloc'ed memory after this.
*/
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
TclFinalizeThreadAlloc();
#endif
TclFinalizeMemorySubsystem();
inFinalize = 0;
}
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()
{
ExitHandler *exitPtr;
ThreadSpecificData *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();
}
/*
* 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()
{
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()
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
return 0;
} else {
return tsdPtr->inExit;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_VwaitObjCmd --
*
* 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_VwaitObjCmd(clientData, interp, objc, objv)
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)) {
return TCL_ERROR;
}
}
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", (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. */
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 (char *) NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpdateObjCmd --
*
* 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_UpdateObjCmd(clientData, interp, objc, objv)
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", (char *) 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)) {
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;
Tcl_Free((char*)clientData); /* Allocated in Tcl_CreateThread() */
(*threadProc)(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThread --
*
* This procedure 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(idPtr, proc, clientData, stackSize, flags)
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*)Tcl_Alloc(sizeof(ThreadClientData));
cdPtr->proc = proc;
cdPtr->clientData = clientData;
return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr,
stackSize, flags);
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
}