summaryrefslogtreecommitdiffstats
path: root/generic/tclEvent.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclEvent.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclEvent.c')
-rw-r--r--generic/tclEvent.c655
1 files changed, 543 insertions, 112 deletions
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 162af15..7499577 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -6,12 +6,12 @@
* command procedures.
*
* Copyright (c) 1990-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* 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.3 1998/09/14 18:39:58 stanton Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.4 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
@@ -28,8 +28,9 @@ typedef struct BgError {
Tcl_Interp *interp; /* Interpreter in which error occurred. NULL
* means this error report has been cancelled
* (a previous report generated a break). */
- char *errorMsg; /* The error message (interp->result when
- * the error occurred). Malloc-ed. */
+ char *errorMsg; /* Copy of the error message (the interp's
+ * result when the error occurred).
+ * Malloc-ed. */
char *errorInfo; /* Value of the errorInfo variable
* (malloc-ed). */
char *errorCode; /* Value of the errorCode variable
@@ -66,27 +67,38 @@ typedef struct ExitHandler {
* this application, or NULL for end of list. */
} ExitHandler;
-static ExitHandler *firstExitPtr = NULL;
- /* First in list of all exit handlers for
- * application. */
-
/*
- * The following variable is a "secret" indication to Tcl_Exit that
- * it should dump out the state of memory before exiting. If the
- * value is non-NULL, it gives the name of the file in which to
- * dump memory usage information.
+ * 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.
*/
-char *tclMemDumpFileName = NULL;
+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_Exit is called, and at the end of
+ * 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 tclInExit = 0;
+static int inFinalize = 0;
+static int subsystemsInitialized = 0;
+static int encodingsInitialized = 0;
+
+static Tcl_Obj *tclLibraryPath = 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;
/*
* Prototypes for procedures referenced only in this file:
@@ -127,6 +139,7 @@ Tcl_BackgroundError(interp)
BgError *errPtr;
char *errResult, *varValue;
ErrAssocData *assocPtr;
+ int length;
/*
* The Tcl_AddErrorInfo call below (with an empty string) ensures that
@@ -138,12 +151,12 @@ Tcl_BackgroundError(interp)
Tcl_AddErrorInfo(interp, "");
- errResult = TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL);
+ errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
errPtr = (BgError *) ckalloc(sizeof(BgError));
errPtr->interp = interp;
- errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(errResult) + 1));
- strcpy(errPtr->errorMsg, errResult);
+ errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (varValue == NULL) {
varValue = errPtr->errorMsg;
@@ -206,7 +219,6 @@ HandleBgErrors(clientData)
ClientData clientData; /* Pointer to ErrAssocData structure. */
{
Tcl_Interp *interp;
- char *command;
char *argv[2];
int code;
BgError *errPtr;
@@ -237,11 +249,10 @@ HandleBgErrors(clientData)
argv[0] = "bgerror";
argv[1] = assocPtr->firstBgPtr->errorMsg;
- command = Tcl_Merge(2, argv);
+
Tcl_AllowExceptions(interp);
Tcl_Preserve((ClientData) interp);
- code = Tcl_GlobalEval(interp, command);
- ckfree(command);
+ code = TclGlobalInvoke(interp, 2, argv, 0);
if (code == TCL_ERROR) {
/*
@@ -256,29 +267,11 @@ HandleBgErrors(clientData)
*/
if (Tcl_IsSafe(interp)) {
- Tcl_HashTable *hTblPtr;
- Tcl_HashEntry *hPtr;
-
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
- "tclHiddenCmds", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- goto doneWithInterp;
- }
- hPtr = Tcl_FindHashEntry(hTblPtr, "bgerror");
- if (hPtr == (Tcl_HashEntry *) NULL) {
- goto doneWithInterp;
- }
-
- /*
- * OK, the hidden command "bgerror" exists, invoke it.
- */
-
- argv[0] = "bgerror";
- argv[1] = ckalloc((unsigned)
- strlen(assocPtr->firstBgPtr->errorMsg));
- strcpy(argv[1], assocPtr->firstBgPtr->errorMsg);
- (void) TclInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
- ckfree(argv[1]);
+ Tcl_SavedResult save;
+
+ Tcl_SaveResult(interp, &save);
+ TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
+ Tcl_RestoreResult(interp, &save);
goto doneWithInterp;
}
@@ -290,22 +283,24 @@ HandleBgErrors(clientData)
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
- if (strcmp(interp->result,
- "\"bgerror\" is an invalid command name or ambiguous abbreviation")
- == 0) {
- Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
- Tcl_Write(errChannel, "\n", -1);
+ char *string;
+ int len;
+
+ string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
+ if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) {
+ Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
+ Tcl_WriteChars(errChannel, "\n", -1);
} else {
- Tcl_Write(errChannel,
+ Tcl_WriteChars(errChannel,
"bgerror failed to handle background error.\n",
-1);
- Tcl_Write(errChannel, " Original error: ", -1);
- Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg,
+ Tcl_WriteChars(errChannel, " Original error: ", -1);
+ Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
-1);
- Tcl_Write(errChannel, "\n", -1);
- Tcl_Write(errChannel, " Error in bgerror: ", -1);
- Tcl_Write(errChannel, interp->result, -1);
- Tcl_Write(errChannel, "\n", -1);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
+ Tcl_WriteChars(errChannel, string, len);
+ Tcl_WriteChars(errChannel, "\n", -1);
}
Tcl_Flush(errChannel);
}
@@ -416,8 +411,10 @@ Tcl_CreateExitHandler(proc, clientData)
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
+ Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
+ Tcl_MutexUnlock(&exitMutex);
}
/*
@@ -446,6 +443,7 @@ Tcl_DeleteExitHandler(proc, clientData)
{
ExitHandler *exitPtr, *prevPtr;
+ Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
@@ -455,6 +453,82 @@ Tcl_DeleteExitHandler(proc, clientData)
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
+ Tcl_MutexUnlock(&exitMutex);
+ ckfree((char *) exitPtr);
+ 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;
}
@@ -484,12 +558,242 @@ Tcl_Exit(status)
* 0 for normal return, 1 for error return. */
{
Tcl_Finalize();
-#ifdef TCL_MEM_DEBUG
- if (tclMemDumpFileName != NULL) {
- Tcl_DumpActiveMemory(tclMemDumpFileName);
+ TclpExit(status);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclSetLibraryPath --
+ *
+ * Set the path that will be used for searching for init.tcl and
+ * encodings when an interp is being created.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Changing the library path will affect what directories are
+ * examined when looking for encodings for all interps from that
+ * point forward.
+ *
+ * The refcount of the new library path is incremented and the
+ * refcount of the old path is decremented.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclSetLibraryPath(pathPtr)
+ Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
+ * the new library path. */
+{
+ Tcl_MutexLock(&exitMutex);
+ if (pathPtr != NULL) {
+ Tcl_IncrRefCount(pathPtr);
+ }
+ if (tclLibraryPath != NULL) {
+ Tcl_DecrRefCount(tclLibraryPath);
+ }
+ tclLibraryPath = pathPtr;
+ Tcl_MutexUnlock(&exitMutex);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclGetLibraryPath --
+ *
+ * Return a Tcl list object whose elements are the library path.
+ * The caller should not modify the contents of the returned object.
+ *
+ * Results:
+ * As above.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetLibraryPath()
+{
+ return tclLibraryPath;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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(argv0)
+ CONST char *argv0; /* Name of executable from argv[0] to main()
+ * in native multi-byte encoding. */
+{
+ ThreadSpecificData *tsdPtr;
+
+ if (inFinalize != 0) {
+ panic("TclInitSubsystems called while finalizing");
}
+
+ /*
+ * Grab the thread local storage pointer before doing anything because
+ * the initialization routines will be registering exit handlers.
+ * We use this pointer to detect if this is the first time this
+ * thread has created an interpreter.
+ */
+
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ 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;
+
+ tclExecutableName = NULL;
+
+ /*
+ * 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();
+#endif
+#ifdef TCL_MEM_DEBUG
+ TclInitDbCkalloc();
#endif
- TclPlatformExit(status);
+
+ TclpInitPlatform();
+ TclInitObjSubsystem();
+ TclInitIOSubsystem();
+ TclInitEncodingSubsystem();
+ TclInitNamespaceSubsystem();
+ }
+ TclpInitUnlock();
+ }
+
+ if (tsdPtr == NULL) {
+ /*
+ * First time this thread has created an interpreter.
+ * We fetch the key again just in case no exit handlers were
+ * registered by this point.
+ */
+
+ (void) TCL_TSD_INIT(&dataKey);
+ TclInitNotifier();
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclFindEncodings --
+ *
+ * Find and load the encoding file for this operating system.
+ * Before this is called, Tcl makes assumptions about the
+ * native string representation, but the true encoding is not
+ * assured.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Varied, see the respective initialization routines.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclFindEncodings(argv0)
+ CONST char *argv0; /* Name of executable from argv[0] to main()
+ * in native multi-byte encoding. */
+{
+ char *native;
+ Tcl_Obj *pathPtr;
+ Tcl_DString libPath, buffer;
+
+ if (encodingsInitialized == 0) {
+ /*
+ * Double check inside the mutex. There may be calls
+ * back into this routine from some of the procedures below.
+ */
+
+ TclpInitLock();
+ if (encodingsInitialized == 0) {
+ /*
+ * Have to set this bit here to avoid deadlock with the
+ * routines below us that call into TclInitSubsystems.
+ */
+
+ encodingsInitialized = 1;
+
+ native = TclpFindExecutable(argv0);
+ TclpInitLibraryPath(native);
+
+ /*
+ * The library path was set in the TclpInitLibraryPath routine.
+ * The string set is a dirty UTF string. To preserve the value
+ * convert the UTF string back to native before setting the new
+ * default encoding.
+ */
+
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr != NULL) {
+ Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1,
+ &libPath);
+ }
+
+ TclpSetInitialEncodings();
+
+ /*
+ * Now convert the native sting back to native string back to UTF.
+ */
+
+ if (pathPtr != NULL) {
+ Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1,
+ &buffer);
+ pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1);
+ TclSetLibraryPath(pathPtr);
+
+ Tcl_DStringFree(&libPath);
+ Tcl_DStringFree(&buffer);
+ }
+ }
+ TclpInitUnlock();
+ }
}
/*
@@ -497,16 +801,16 @@ Tcl_Exit(status)
*
* Tcl_Finalize --
*
- * Runs the exit handlers to allow Tcl to clean up its state prior
- * to being unloaded. Called by Tcl_Exit and when Tcl was dynamically
- * loaded and is now being unloaded.
+ * 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:
- * Whatever the exit handlers do. Also frees up storage associated
- * with the Tcl object type table.
+ * Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
@@ -515,34 +819,150 @@ void
Tcl_Finalize()
{
ExitHandler *exitPtr;
+
+ TclpInitLock();
+ if (subsystemsInitialized != 0) {
+ subsystemsInitialized = 0;
+ encodingsInitialized = 0;
+
+ /*
+ * 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);
+
+ /*
+ * 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.
+ */
- /*
- * Invoke exit handler first.
- */
+ 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();
+
+ TclFinalizeEncodingSubsystem();
+
+ if (tclLibraryPath != NULL) {
+ Tcl_DecrRefCount(tclLibraryPath);
+ tclLibraryPath = NULL;
+ }
+ if (tclExecutableName != NULL) {
+ ckfree(tclExecutableName);
+ tclExecutableName = NULL;
+ }
+ if (tclNativeExecutableName != NULL) {
+ ckfree(tclNativeExecutableName);
+ tclNativeExecutableName = NULL;
+ }
+ if (tclDefaultEncodingDir != NULL) {
+ ckfree(tclDefaultEncodingDir);
+ tclDefaultEncodingDir = NULL;
+ }
+
+ Tcl_SetPanicProc(NULL);
+
+ /*
+ * 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.
+ */
+
+ TclFinalizeLoad();
- tclInExit = 1;
- for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
/*
- * Be careful to remove the handler from the list before invoking
- * its callback. This protects us against double-freeing if the
- * callback should call Tcl_DeleteExitHandler on itself.
+ * There shouldn't be any malloc'ed memory after this.
*/
- firstExitPtr = exitPtr->nextPtr;
- (*exitPtr->proc)(exitPtr->clientData);
- ckfree((char *) exitPtr);
+ TclFinalizeMemorySubsystem();
+ inFinalize = 0;
}
+ TclpInitUnlock();
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * Now finalize the Tcl execution environment. Note that this must be done
- * after the exit handlers, because there are order dependencies.
- */
-
- TclFinalizeCompExecEnv();
- TclFinalizeEnvironment();
- TclpFinalize();
- firstExitPtr = NULL;
- tclInExit = 0;
+void
+Tcl_FinalizeThread()
+{
+ ExitHandler *exitPtr;
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+
+ if (tsdPtr != NULL) {
+ /*
+ * Invoke thread exit handlers first.
+ */
+
+ 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();
+
+ /*
+ * Blow away all thread local storage blocks.
+ */
+
+ TclFinalizeThreadData();
+ }
}
/*
@@ -564,13 +984,14 @@ Tcl_Finalize()
int
TclInExit()
{
- return tclInExit;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ return tsdPtr->inExit;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_VwaitCmd --
+ * Tcl_VwaitObjCmd --
*
* This procedure is invoked to process the "vwait" Tcl command.
* See the user documentation for details on what it does.
@@ -586,20 +1007,21 @@ TclInExit()
/* ARGSUSED */
int
-Tcl_VwaitCmd(clientData, interp, argc, argv)
+Tcl_VwaitObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int done, foundEvent;
+ char *nameString;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " name\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- if (Tcl_TraceVar(interp, argv[1],
+ 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;
@@ -609,7 +1031,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv)
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
- Tcl_UntraceVar(interp, argv[1],
+ Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done);
@@ -620,7 +1042,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv)
Tcl_ResetResult(interp);
if (!foundEvent) {
- Tcl_AppendResult(interp, "can't wait for variable \"", argv[1],
+ Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
"\": would wait forever", (char *) NULL);
return TCL_ERROR;
}
@@ -645,7 +1067,7 @@ VwaitVarProc(clientData, interp, name1, name2, flags)
/*
*----------------------------------------------------------------------
*
- * Tcl_UpdateCmd --
+ * Tcl_UpdateObjCmd --
*
* This procedure is invoked to process the "update" Tcl command.
* See the user documentation for details on what it does.
@@ -661,29 +1083,38 @@ VwaitVarProc(clientData, interp, name1, name2, flags)
/* ARGSUSED */
int
-Tcl_UpdateCmd(clientData, interp, argc, argv)
+Tcl_UpdateObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int flags;
+ int optionIndex;
+ int flags = 0; /* Initialized to avoid compiler warning. */
+ static char *updateOptions[] = {"idletasks", (char *) NULL};
+ enum updateOptions {REGEXP_IDLETASKS};
- if (argc == 1) {
+ if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
- } else if (argc == 2) {
- if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be idletasks", (char *) NULL);
+ } else if (objc == 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ switch ((enum updateOptions) optionIndex) {
+ case REGEXP_IDLETASKS: {
+ flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ break;
+ }
+ default: {
+ panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
+ }
+ }
} else {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " ?idletasks?\"", (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
return TCL_ERROR;
}
-
+
while (Tcl_DoOneEvent(flags) != 0) {
/* Empty loop body */
}