summaryrefslogtreecommitdiffstats
path: root/generic/tclEvent.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclEvent.c')
-rw-r--r--generic/tclEvent.c603
1 files changed, 437 insertions, 166 deletions
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index b2fc70e..941d566 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -11,8 +11,6 @@
*
* 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.68 2006/09/19 22:07:34 dkf Exp $
*/
#include "tclInt.h"
@@ -51,8 +49,8 @@ typedef struct ErrAssocData {
} ErrAssocData;
/*
- * For each exit handler created with a call to Tcl_CreateExitHandler there is
- * a structure of the following type:
+ * For each exit handler created with a call to Tcl_Create(Late)ExitHandler
+ * there is a structure of the following type:
*/
typedef struct ExitHandler {
@@ -70,22 +68,25 @@ typedef struct ExitHandler {
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.
+ * This variable is set to 1 when Tcl_Exit is called. 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 inExit = 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.
+ * 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;
@@ -114,8 +115,10 @@ static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
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);
+static char * VwaitVarProc(ClientData clientData,
+ Tcl_Interp *interp, const char *name1,
+ const char *name2, int flags);
+static void InvokeExitHandlers(void);
/*
*----------------------------------------------------------------------
@@ -140,21 +143,34 @@ Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
* occurred. */
{
+ Tcl_BackgroundException(interp, TCL_ERROR);
+}
+
+void
+Tcl_BackgroundException(
+ Tcl_Interp *interp, /* Interpreter in which an exception has
+ * occurred. */
+ int code) /* The exception code value */
+{
BgError *errPtr;
ErrAssocData *assocPtr;
- errPtr = (BgError *) ckalloc(sizeof(BgError));
+ if (code == TCL_OK) {
+ return;
+ }
+
+ errPtr = ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
- errPtr->returnOpts = Tcl_GetReturnOptions(interp, TCL_ERROR);
+ errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
- assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL);
+ assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
- Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
} else {
assocPtr->lastBgPtr->nextPtr = errPtr;
}
@@ -183,7 +199,7 @@ static void
HandleBgErrors(
ClientData clientData) /* Pointer to ErrAssocData structure. */
{
- ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ ErrAssocData *assocPtr = clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
@@ -194,18 +210,23 @@ HandleBgErrors(
* that could lead us here.
*/
- Tcl_Preserve((ClientData) assocPtr);
- Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve(assocPtr);
+ Tcl_Preserve(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_IncrRefCount(assocPtr->cmdPrefix);
- Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix, &prefixObjc,
- &prefixObjv);
- tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
+ Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
+ tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
@@ -216,12 +237,12 @@ HandleBgErrors(
* Discard the command and the information about the error report.
*/
- Tcl_DecrRefCount(assocPtr->cmdPrefix);
+ Tcl_DecrRefCount(copyObj);
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
- ckfree((char *) errPtr);
- ckfree((char *) tempObjv);
+ ckfree(errPtr);
+ ckfree(tempObjv);
if (code == TCL_BREAK) {
/*
@@ -234,16 +255,16 @@ HandleBgErrors(
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
- ckfree((char *) errPtr);
+ ckfree(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
+ if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
- Tcl_Obj *keyPtr = Tcl_NewStringObj("-errorinfo", -1);
- Tcl_Obj *valuePtr;
+ Tcl_Obj *keyPtr, *valuePtr;
+ TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
@@ -257,12 +278,13 @@ HandleBgErrors(
}
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_Flush(errChannel);
+ Tcl_DecrRefCount(options);
}
}
}
assocPtr->lastBgPtr = NULL;
- Tcl_Release((ClientData) interp);
- Tcl_Release((ClientData) assocPtr);
+ Tcl_Release(interp);
+ Tcl_Release(assocPtr);
}
/*
@@ -288,11 +310,12 @@ TclDefaultBgErrorHandlerObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *keyPtr, *valuePtr;
Tcl_Obj *tempObjv[2];
- int code;
+ int code, level;
+ Tcl_InterpState saved;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "msg options");
@@ -300,37 +323,118 @@ TclDefaultBgErrorHandlerObjCmd(
}
/*
- * 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.
+ * Check for a valid return options dictionary.
*/
- keyPtr = Tcl_NewStringObj("-errorcode", -1);
+ 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));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ 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));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ 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 Tcl_BackgroundException()?) 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_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
+ Tcl_SetObjErrorCode(interp, valuePtr);
}
- keyPtr = Tcl_NewStringObj("-errorinfo", -1);
+ TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
- Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
+ Tcl_AppendObjToErrorInfo(interp, valuePtr);
+ }
+
+ if (code == TCL_ERROR) {
+ Tcl_SetObjResult(interp, tempObjv[1]);
}
/*
- * Create and invoke the bgerror command.
+ * Save interpreter state so we can restore it if multiple handler
+ * attempts are needed.
+ */
+
+ saved = Tcl_SaveInterpState(interp, code);
+
+ /*
+ * 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) {
@@ -345,25 +449,27 @@ TclDefaultBgErrorHandlerObjCmd(
*/
if (Tcl_IsSafe(interp)) {
- Tcl_ResetResult(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) {
+
+ if (errChannel != 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);
- }
+ 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, objv[1]);
+ Tcl_WriteObj(errChannel, tempObjv[1]);
Tcl_WriteChars(errChannel, "\n", -1);
Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
Tcl_WriteObj(errChannel, resultPtr);
@@ -371,11 +477,17 @@ TclDefaultBgErrorHandlerObjCmd(
}
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;
}
@@ -402,8 +514,7 @@ TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
- ErrAssocData *assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
@@ -413,13 +524,12 @@ TclSetBgErrorHandler(
* First access: initialize.
*/
- assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
+ assocPtr = ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
- Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
- (ClientData) assocPtr);
+ Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
}
if (assocPtr->cmdPrefix) {
Tcl_DecrRefCount(assocPtr->cmdPrefix);
@@ -449,13 +559,14 @@ Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
- ErrAssocData *assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
- TclSetBgErrorHandler(interp, Tcl_NewStringObj("::tcl::Bgerror", -1));
- assocPtr = (ErrAssocData *)
- Tcl_GetAssocData(interp, "tclBgError", NULL);
+ Tcl_Obj *bgerrorObj;
+
+ TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
+ TclSetBgErrorHandler(interp, bgerrorObj);
+ assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
@@ -474,7 +585,7 @@ TclGetBgErrorHandler(
*
* Side effects:
* Background error information is freed: if there were any pending error
- * reports, they are cancelled.
+ * reports, they are canceled.
*
*----------------------------------------------------------------------
*/
@@ -484,7 +595,7 @@ BgErrorDeleteProc(
ClientData clientData, /* Pointer to ErrAssocData structure. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
- ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ ErrAssocData *assocPtr = clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
@@ -492,11 +603,11 @@ BgErrorDeleteProc(
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
- ckfree((char *) errPtr);
+ ckfree(errPtr);
}
- Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
+ Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
Tcl_DecrRefCount(assocPtr->cmdPrefix);
- Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
+ Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC);
}
/*
@@ -522,9 +633,8 @@ Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
- ExitHandler *exitPtr;
+ ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
@@ -536,6 +646,39 @@ Tcl_CreateExitHandler(
/*
*----------------------------------------------------------------------
*
+ * 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 = 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
@@ -546,7 +689,7 @@ Tcl_CreateExitHandler(
*
* 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.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -568,7 +711,50 @@ Tcl_DeleteExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(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(exitPtr);
break;
}
}
@@ -602,7 +788,7 @@ Tcl_CreateThreadExitHandler(
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+ exitPtr = ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
@@ -622,7 +808,7 @@ Tcl_CreateThreadExitHandler(
*
* 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.
+ * it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
@@ -644,7 +830,7 @@ Tcl_DeleteThreadExitHandler(
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
- ckfree((char *) exitPtr);
+ ckfree(exitPtr);
return;
}
}
@@ -686,6 +872,49 @@ Tcl_SetExitProc(
return prevExitProc;
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InvokeExitHandlers --
+ *
+ * Call the registered exit handlers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The exit handlers are invoked, and the ExitHandler struct is
+ * freed.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+InvokeExitHandlers(void)
+{
+ ExitHandler *exitPtr;
+
+ Tcl_MutexLock(&exitMutex);
+ inExit = 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(exitPtr);
+ Tcl_MutexLock(&exitMutex);
+ }
+ firstExitPtr = NULL;
+ Tcl_MutexUnlock(&exitMutex);
+}
+
/*
*----------------------------------------------------------------------
@@ -721,14 +950,41 @@ Tcl_Exit(
* returns, so critical is this dependcy.
*/
- currentAppExitPtr((ClientData) status);
+ currentAppExitPtr(INT2PTR(status));
Tcl_Panic("AppExitProc returned unexpectedly");
} else {
- /*
- * Use default handling.
- */
- Tcl_Finalize();
+ if (TclFullFinalizationRequested()) {
+
+ /*
+ * Thorough finalization for Valgrind et al.
+ */
+
+ Tcl_Finalize();
+
+ } else {
+
+ /*
+ * Fast and deterministic exit (default behavior)
+ */
+
+ InvokeExitHandlers();
+
+ /*
+ * Ensure the thread-specific data is initialised as it is used in
+ * Tcl_FinalizeThread()
+ */
+
+ (void) TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Now finalize the calling thread only (others are not safely
+ * reachable). Among other things, this triggers a flush of the
+ * Tcl_Channels that may have data enqueued.
+ */
+
+ Tcl_FinalizeThread();
+ }
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
@@ -762,8 +1018,8 @@ Tcl_Exit(
void
TclInitSubsystems(void)
{
- if (inFinalize != 0) {
- Tcl_Panic("TclInitSubsystems called while finalizing");
+ if (inExit != 0) {
+ Tcl_Panic("TclInitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
@@ -774,14 +1030,8 @@ TclInitSubsystems(void)
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.
@@ -799,12 +1049,13 @@ TclInitSubsystems(void)
TclpInitPlatform(); /* Creates signal handler(s) */
TclInitDoubleConversion(); /* Initializes constants for
* converting to/from double. */
- TclInitObjSubsystem(); /* Register obj types, create
+ TclInitObjSubsystem(); /* Register obj types, create
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclpSetInterfaces();
- TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ subsystemsInitialized = 1;
}
TclpInitUnlock();
}
@@ -817,8 +1068,8 @@ TclInitSubsystems(void)
* 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.
+ * shuts down various subsystems. Should be invoked by user before the
+ * Tcl shared library is being unloaded in an embedded context.
*
* Results:
* None.
@@ -838,23 +1089,7 @@ Tcl_Finalize(void)
* 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);
+ InvokeExitHandlers();
TclpInitLock();
if (subsystemsInitialized == 0) {
@@ -879,11 +1114,33 @@ Tcl_Finalize(void)
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(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.
*/
- TclFinalizeCompilation();
+ TclFinalizeEvaluation();
TclFinalizeExecution();
TclFinalizeEnvironment();
@@ -914,8 +1171,6 @@ Tcl_Finalize(void)
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
@@ -939,10 +1194,10 @@ Tcl_Finalize(void)
/*
* 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.
+ * malloc'ed memory, and Tcl_FinalizeMemorySubsystem or
+ * Tcl_FinalizeThreadAlloc 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) {
@@ -989,7 +1244,6 @@ Tcl_Finalize(void)
*/
TclFinalizeMemorySubsystem();
- inFinalize = 0;
alreadyFinalized:
TclFinalizeLock();
@@ -1024,7 +1278,7 @@ Tcl_FinalizeThread(void)
* initialized already.
*/
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ tsdPtr = TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
@@ -1037,12 +1291,13 @@ Tcl_FinalizeThread(void)
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
- (*exitPtr->proc)(exitPtr->clientData);
- ckfree((char *) exitPtr);
+ exitPtr->proc(exitPtr->clientData);
+ ckfree(exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
+ TclFinalizeThreadObjects();
}
/*
@@ -1077,7 +1332,7 @@ Tcl_FinalizeThread(void)
int
TclInExit(void)
{
- return inFinalize;
+ return inExit;
}
/*
@@ -1099,13 +1354,12 @@ TclInExit(void)
int
TclInThreadExit(void)
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- TclThreadDataKeyGet(&dataKey);
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+
if (tsdPtr == NULL) {
return 0;
- } else {
- return tsdPtr->inExit;
}
+ return tsdPtr->inExit;
}
/*
@@ -1131,48 +1385,61 @@ Tcl_VwaitObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
int done, foundEvent;
- char *nameString;
+ const char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
nameString = Tcl_GetString(objv[1]);
- if (Tcl_TraceVar(interp, nameString,
+ if (Tcl_TraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, (ClientData) &done) != TCL_OK) {
+ VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
};
done = 0;
foundEvent = 1;
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ break;
+ }
if (Tcl_LimitExceeded(interp)) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
break;
}
}
- Tcl_UntraceVar(interp, nameString,
+ Tcl_UntraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, (ClientData) &done);
+ VwaitVarProc, &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);
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't wait for variable \"%s\": would wait forever",
+ nameString));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
return TCL_ERROR;
}
if (!done) {
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ /*
+ * The interpreter's result was already set to the right error message
+ * prior to exiting the loop above.
+ */
+
return TCL_ERROR;
}
+
+ /*
+ * Clear out the interpreter's result, since it may have been set by event
+ * handlers.
+ */
+
+ Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -1181,11 +1448,11 @@ 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. */
+ const char *name1, /* Name of variable. */
+ const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
- int *donePtr = (int *) clientData;
+ int *donePtr = clientData;
*donePtr = 1;
return NULL;
@@ -1214,12 +1481,12 @@ Tcl_UpdateObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
- Tcl_Obj *CONST objv[]) /* Argument objects. */
+ 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};
+ static const char *const updateOptions[] = {"idletasks", NULL};
+ enum updateOptions {OPT_IDLETASKS};
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
@@ -1229,7 +1496,7 @@ Tcl_UpdateObjCmd(
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
- case REGEXP_IDLETASKS:
+ case OPT_IDLETASKS:
flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
@@ -1241,9 +1508,12 @@ Tcl_UpdateObjCmd(
}
while (Tcl_DoOneEvent(flags) != 0) {
+ if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "limit exceeded", NULL);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
return TCL_ERROR;
}
}
@@ -1259,11 +1529,11 @@ Tcl_UpdateObjCmd(
#ifdef TCL_THREADS
/*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* NewThreadProc --
*
- * Bootstrap function of a new Tcl thread.
+ * Bootstrap function of a new Tcl thread.
*
* Results:
* None.
@@ -1271,23 +1541,22 @@ Tcl_UpdateObjCmd(
* Side Effects:
* Initializes Tcl notifier for the current thread.
*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(
ClientData clientData)
{
- ThreadClientData *cdPtr;
+ ThreadClientData *cdPtr = clientData;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
- cdPtr = (ThreadClientData *) clientData;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
- Tcl_Free((char *) clientData); /* Allocated in Tcl_CreateThread() */
+ ckfree(clientData); /* Allocated in Tcl_CreateThread() */
- (*threadProc)(threadClientData);
+ threadProc(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
@@ -1315,21 +1584,23 @@ NewThreadProc(
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
- Tcl_ThreadCreateProc proc, /* Main() function 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;
+ ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData));
+ int result;
- cdPtr = (ThreadClientData *) Tcl_Alloc(sizeof(ThreadClientData));
cdPtr->proc = proc;
cdPtr->clientData = clientData;
-
- return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr,
- stackSize, flags);
+ result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
+ if (result != TCL_OK) {
+ ckfree(cdPtr);
+ }
+ return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
generated by cgit v0.12 at 2025-10-31 10:15:07 (GMT)