--- /dev/null
+/*
+ * 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.
+ */
+
+#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_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 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.
+ */
+
+static TCL_NORETURN1 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);
+static void InvokeExitHandlers(void);
+static void FinalizeThread(int quick);
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ 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;
+
+ if (code == TCL_OK) {
+ return;
+ }
+
+ errPtr = 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 = Tcl_GetAssocData(interp, "tclBgError", NULL);
+ if (assocPtr->firstBgPtr == NULL) {
+ assocPtr->firstBgPtr = errPtr;
+ Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
+ } else {
+ assocPtr->lastBgPtr->nextPtr = errPtr;
+ }
+ assocPtr->lastBgPtr = errPtr;
+ Tcl_ResetResult(interp);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = 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(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_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;
+ 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(errPtr);
+ ckfree(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(errPtr);
+ }
+ } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
+ Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
+
+ if (errChannel != NULL) {
+ Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
+ Tcl_Obj *keyPtr, *valuePtr = NULL;
+
+ 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);
+ Tcl_DecrRefCount(options);
+ }
+ }
+ }
+ assocPtr->lastBgPtr = NULL;
+ Tcl_Release(interp);
+ Tcl_Release(assocPtr);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 result, 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);
+ result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (result != TCL_OK || 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);
+ result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (result != TCL_OK || 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);
+ result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (result == TCL_OK && valuePtr != NULL) {
+ Tcl_SetObjErrorCode(interp, valuePtr);
+ }
+
+ TclNewLiteralStringObj(keyPtr, "-errorinfo");
+ Tcl_IncrRefCount(keyPtr);
+ result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (result == TCL_OK && valuePtr != NULL) {
+ 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 != 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = Tcl_GetAssocData(interp, "tclBgError", NULL);
+
+ if (cmdPrefix == NULL) {
+ Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
+ }
+ if (assocPtr == NULL) {
+ /*
+ * First access: initialize.
+ */
+
+ assocPtr = ckalloc(sizeof(ErrAssocData));
+ assocPtr->interp = interp;
+ assocPtr->cmdPrefix = NULL;
+ assocPtr->firstBgPtr = NULL;
+ assocPtr->lastBgPtr = NULL;
+ Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
+ }
+ if (assocPtr->cmdPrefix) {
+ Tcl_DecrRefCount(assocPtr->cmdPrefix);
+ }
+ assocPtr->cmdPrefix = cmdPrefix;
+ Tcl_IncrRefCount(assocPtr->cmdPrefix);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = Tcl_GetAssocData(interp, "tclBgError", NULL);
+
+ if (assocPtr == NULL) {
+ Tcl_Obj *bgerrorObj;
+
+ TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
+ TclSetBgErrorHandler(interp, bgerrorObj);
+ assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
+ }
+ return assocPtr->cmdPrefix;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 canceled.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+BgErrorDeleteProc(
+ ClientData clientData, /* Pointer to ErrAssocData structure. */
+ Tcl_Interp *interp) /* Interpreter being deleted. */
+{
+ ErrAssocData *assocPtr = clientData;
+ BgError *errPtr;
+
+ while (assocPtr->firstBgPtr != NULL) {
+ errPtr = assocPtr->firstBgPtr;
+ assocPtr->firstBgPtr = errPtr->nextPtr;
+ Tcl_DecrRefCount(errPtr->errorMsg);
+ Tcl_DecrRefCount(errPtr->returnOpts);
+ ckfree(errPtr);
+ }
+ Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
+ Tcl_DecrRefCount(assocPtr->cmdPrefix);
+ Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = ckalloc(sizeof(ExitHandler));
+
+ exitPtr->proc = proc;
+ exitPtr->clientData = clientData;
+ Tcl_MutexLock(&exitMutex);
+ exitPtr->nextPtr = firstExitPtr;
+ firstExitPtr = exitPtr;
+ Tcl_MutexUnlock(&exitMutex);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 canceled; 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(exitPtr);
+ break;
+ }
+ }
+ Tcl_MutexUnlock(&exitMutex);
+ return;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ }
+ }
+ Tcl_MutexUnlock(&exitMutex);
+ return;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = ckalloc(sizeof(ExitHandler));
+ exitPtr->proc = proc;
+ exitPtr->clientData = clientData;
+ exitPtr->nextPtr = tsdPtr->firstExitPtr;
+ tsdPtr->firstExitPtr = exitPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 canceled; 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(exitPtr);
+ return;
+ }
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_NORETURN1 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;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Exit --
+ *
+ * This function is called to terminate the application.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * All existing exit handlers are invoked, then the application ends.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TCL_NORETURN void
+Tcl_Exit(
+ int status) /* Exit status for application; typically 0
+ * for normal return, 1 for error return. */
+{
+ TCL_NORETURN1 Tcl_ExitProc *currentAppExitPtr;
+
+ Tcl_MutexLock(&exitMutex);
+ currentAppExitPtr = appExitPtr;
+ Tcl_MutexUnlock(&exitMutex);
+
+ /*
+ * Warning: this function 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.
+ *
+ * If subsystems are not (yet) initialized, proper Tcl-finalization is
+ * impossible, so fallback to system exit, see bug-[f8a33ce3db5d8cc2].
+ */
+
+ if (currentAppExitPtr) {
+
+ currentAppExitPtr(INT2PTR(status));
+
+ } else if (subsystemsInitialized) {
+
+ 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.
+ */
+
+ FinalizeThread(/* quick */ 1);
+ }
+ }
+
+ TclpExit(status);
+ Tcl_Panic("OS exit failed!");
+}
+\f
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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 (inExit != 0) {
+ Tcl_Panic("TclInitSubsystems called while exiting");
+ }
+
+ 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) {
+
+ /*
+ * 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 hash table for
+ * thread local storage */
+#if defined(USE_TCLALLOC) && 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. */
+ TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ subsystemsInitialized = 1;
+ }
+ TclpInitUnlock();
+ }
+ TclInitNotifier();
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Finalize --
+ *
+ * Shut down Tcl. First calls registered exit handlers, then carefully
+ * shuts down various subsystems. Should be invoked by user before the
+ * Tcl shared library is being unloaded in an embedded context.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Varied, see the respective finalization routines.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_Finalize(void)
+{
+ ExitHandler *exitPtr;
+
+ /*
+ * Invoke exit handlers first.
+ */
+
+ InvokeExitHandlers();
+
+ 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(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.
+ */
+
+ TclFinalizeEvaluation();
+ 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 global 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();
+
+ /*
+ * 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(/* quick */ 0);
+
+ /*
+ * 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_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) {
+ 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();
+
+ alreadyFinalized:
+ TclFinalizeLock();
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)
+{
+ FinalizeThread(/* quick */ 0);
+}
+
+void
+FinalizeThread(
+ int quick)
+{
+ 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 = 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(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(quick);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 inExit;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = TclThreadDataKeyGet(&dataKey);
+
+ if (tsdPtr == NULL) {
+ return 0;
+ }
+ return tsdPtr->inExit;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ const char *nameString;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
+ return TCL_ERROR;
+ }
+ nameString = Tcl_GetString(objv[1]);
+ if (Tcl_TraceVar2(interp, nameString, NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ 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_UntraceVar2(interp, nameString, NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &done);
+
+ if (!foundEvent) {
+ 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) {
+ /*
+ * 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;
+}
+
+ /* 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 = clientData;
+
+ *donePtr = 1;
+ Tcl_UntraceVar(interp, name1, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, clientData);
+ return NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 *const updateOptions[] = {"idletasks", NULL};
+ enum updateOptions {OPT_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 OPT_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_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (Tcl_LimitExceeded(interp)) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Must clear the interpreter's result because event handlers could have
+ * executed commands.
+ */
+
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+}
+\f
+#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;
+ ClientData threadClientData;
+ Tcl_ThreadCreateProc *threadProc;
+
+ threadProc = cdPtr->proc;
+ threadClientData = cdPtr->clientData;
+ ckfree(clientData); /* Allocated in Tcl_CreateThread() */
+
+ threadProc(threadClientData);
+
+ TCL_THREAD_CREATE_RETURN;
+}
+#endif
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = ckalloc(sizeof(ThreadClientData));
+ int result;
+
+ cdPtr->proc = proc;
+ cdPtr->clientData = clientData;
+ result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
+ if (result != TCL_OK) {
+ ckfree(cdPtr);
+ }
+ return result;
+#else
+ return TCL_ERROR;
+#endif /* TCL_THREADS */
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
