diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclEvent.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclEvent.c Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,1281 @@ +/* + * tclEvent.c -- + * + * This file implements some general event related interfaces including + * background errors, exit handlers, and the "vwait" and "update" + * command procedures. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. + * + * 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.28.2.15 2007/03/19 17:06:25 dgp Exp $ + */ + +#include "tclInt.h" +#include "tclPort.h" +#if defined(__SYMBIAN32__) && defined(__WINSCW__) +#include "tclSymbianGlobals.h" +#define dataKey getdataKey(0) +#endif + +/* + * 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 bgerror can be invoked + * later as an idle handler. + */ + +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; /* 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 + * (malloc-ed). */ + 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 { + BgError *firstBgPtr; /* First in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ + BgError *lastBgPtr; /* Last in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ +} ErrAssocData; + +/* + * For each exit handler created with a call to Tcl_CreateExitHandler + * there is a structure of the following type: + */ + +typedef struct ExitHandler { + Tcl_ExitProc *proc; /* Procedure to call when process exits. */ + ClientData clientData; /* One word of information to pass to proc. */ + struct ExitHandler *nextPtr;/* Next in list of all exit handlers for + * this application, or NULL for end of list. */ +} ExitHandler; + +/* + * There is both per-process and per-thread exit handlers. + * The first list is controlled by a mutex. The other is in + * thread local storage. + */ + +static ExitHandler *firstExitPtr = NULL; + /* First in list of all exit handlers for + * application. */ +TCL_DECLARE_MUTEX(exitMutex) + +/* + * This variable is set to 1 when Tcl_Finalize is called, and at the end of + * its work, it is reset to 0. The variable is checked by TclInExit() to + * allow different behavior for exit-time processing, e.g. in closing of + * files and pipes. + */ +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__) +static int inFinalize = 0; +static int subsystemsInitialized = 0; +#endif + +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. */ + Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */ +} ThreadSpecificData; +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__) +static Tcl_ThreadDataKey dataKey; + +/* + * Common string for the library path for sharing across threads. + * This is ckalloc'd and cleared in Tcl_Finalize. + */ +static char *tclLibraryPathStr = NULL; +#endif + +#ifdef TCL_THREADS + +typedef struct { + Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ + ClientData clientData; /* The one argument to Main() */ +} ThreadClientData; +static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_(( + ClientData clientData)); +#endif + +/* + * Prototypes for procedures referenced only in this file: + */ + +static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); +static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_BackgroundError -- + * + * This procedure is invoked to handle errors that occur in Tcl + * commands that are invoked in "background" (e.g. from event or + * timer bindings). + * + * Results: + * None. + * + * Side effects: + * The command "bgerror" is invoked later as an idle handler to + * process the error, passing it the error message. If that fails, + * then an error message is output on stderr. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_BackgroundError(interp) + Tcl_Interp *interp; /* Interpreter in which an error has + * occurred. */ +{ + BgError *errPtr; + CONST char *errResult, *varValue; + ErrAssocData *assocPtr; + int length; + + /* + * The Tcl_AddErrorInfo call below (with an empty string) ensures that + * errorInfo gets properly set. It's needed in cases where the error + * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval; + * in these cases errorInfo still won't have been set when this + * procedure is called. + */ + + Tcl_AddErrorInfo(interp, ""); + + errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + + errPtr = (BgError *) ckalloc(sizeof(BgError)); + errPtr->interp = interp; + 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; + } + errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorInfo, varValue); + varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + if (varValue == NULL) { + varValue = ""; + } + errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorCode, varValue); + errPtr->nextPtr = NULL; + + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", + (Tcl_InterpDeleteProc **) NULL); + if (assocPtr == NULL) { + + /* + * This is the first time a background error has occurred in + * this interpreter. Create associated data to keep track of + * pending error reports. + */ + + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); + assocPtr->firstBgPtr = NULL; + assocPtr->lastBgPtr = NULL; + Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, + (ClientData) assocPtr); + } + if (assocPtr->firstBgPtr == NULL) { + assocPtr->firstBgPtr = errPtr; + Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); + } else { + assocPtr->lastBgPtr->nextPtr = errPtr; + } + assocPtr->lastBgPtr = errPtr; + Tcl_ResetResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * HandleBgErrors -- + * + * This procedure is invoked as an idle handler to process all of + * the accumulated background errors. + * + * Results: + * None. + * + * Side effects: + * Depends on what actions "bgerror" takes for the errors. + * + *---------------------------------------------------------------------- + */ + +static void +HandleBgErrors(clientData) + ClientData clientData; /* Pointer to ErrAssocData structure. */ +{ + Tcl_Interp *interp; + CONST char *argv[2]; + int code; + BgError *errPtr; + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + Tcl_Channel errChannel; + + Tcl_Preserve((ClientData) assocPtr); + + while (assocPtr->firstBgPtr != NULL) { + interp = assocPtr->firstBgPtr->interp; + if (interp == NULL) { + goto doneWithInterp; + } + + /* + * Restore important state variables to what they were at + * the time the error occurred. + */ + + Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo, + TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode, + TCL_GLOBAL_ONLY); + + /* + * Create and invoke the bgerror command. + */ + + argv[0] = "bgerror"; + argv[1] = assocPtr->firstBgPtr->errorMsg; + + Tcl_AllowExceptions(interp); + Tcl_Preserve((ClientData) interp); + code = TclGlobalInvoke(interp, 2, argv, 0); + 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_SavedResult save; + + Tcl_SaveResult(interp, &save); + TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN); + Tcl_RestoreResult(interp, &save); + + goto doneWithInterp; + } + + /* + * We have to get the error output channel at the latest possible + * time, because the eval (above) might have changed the channel. + */ + + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + char *string; + int len; + + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len); + if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) { + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1); + Tcl_WriteChars(errChannel, "\n", -1); + } else { + Tcl_WriteChars(errChannel, + "bgerror failed to handle background error.\n", + -1); + Tcl_WriteChars(errChannel, " Original error: ", -1); + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg, + -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); + } + } else if (code == TCL_BREAK) { + + /* + * Break means cancel any remaining error reports for this + * interpreter. + */ + + for (errPtr = assocPtr->firstBgPtr; errPtr != NULL; + errPtr = errPtr->nextPtr) { + if (errPtr->interp == interp) { + errPtr->interp = NULL; + } + } + } + + /* + * Discard the command and the information about the error report. + */ + +doneWithInterp: + + if (assocPtr->firstBgPtr) { + ckfree(assocPtr->firstBgPtr->errorMsg); + ckfree(assocPtr->firstBgPtr->errorInfo); + ckfree(assocPtr->firstBgPtr->errorCode); + errPtr = assocPtr->firstBgPtr->nextPtr; + ckfree((char *) assocPtr->firstBgPtr); + assocPtr->firstBgPtr = errPtr; + } + + if (interp != NULL) { + Tcl_Release((ClientData) interp); + } + } + assocPtr->lastBgPtr = NULL; + + Tcl_Release((ClientData) assocPtr); +} + +/* + *---------------------------------------------------------------------- + * + * BgErrorDeleteProc -- + * + * This procedure is associated with the "tclBgError" assoc data + * for an interpreter; it is invoked when the interpreter is + * deleted in order to free the information assoicated with any + * pending error reports. + * + * Results: + * None. + * + * Side effects: + * Background error information is freed: if there were any + * pending error reports, they are cancelled. + * + *---------------------------------------------------------------------- + */ + +static void +BgErrorDeleteProc(clientData, interp) + ClientData clientData; /* Pointer to ErrAssocData structure. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + BgError *errPtr; + + while (assocPtr->firstBgPtr != NULL) { + errPtr = assocPtr->firstBgPtr; + assocPtr->firstBgPtr = errPtr->nextPtr; + ckfree(errPtr->errorMsg); + ckfree(errPtr->errorInfo); + ckfree(errPtr->errorCode); + ckfree((char *) errPtr); + } + Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); + Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateExitHandler -- + * + * Arrange for a given procedure to be invoked just before the + * application exits. + * + * Results: + * None. + * + * Side effects: + * Proc will be invoked with clientData as argument when the + * application exits. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_CreateExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr; + + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + exitPtr->proc = proc; + exitPtr->clientData = clientData; + Tcl_MutexLock(&exitMutex); + exitPtr->nextPtr = firstExitPtr; + firstExitPtr = exitPtr; + Tcl_MutexUnlock(&exitMutex); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteExitHandler -- + * + * This procedure cancels an existing exit handler matching proc + * and clientData, if such a handler exits. + * + * Results: + * None. + * + * Side effects: + * If there is an exit handler corresponding to proc and clientData + * then it is cancelled; if no such handler exists then nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_DeleteExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr, *prevPtr; + + Tcl_MutexLock(&exitMutex); + for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { + if ((exitPtr->proc == proc) + && (exitPtr->clientData == clientData)) { + if (prevPtr == NULL) { + firstExitPtr = exitPtr->nextPtr; + } else { + prevPtr->nextPtr = exitPtr->nextPtr; + } + ckfree((char *) exitPtr); + break; + } + } + Tcl_MutexUnlock(&exitMutex); + return; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateThreadExitHandler -- + * + * Arrange for a given procedure to be invoked just before the + * current thread exits. + * + * Results: + * None. + * + * Side effects: + * Proc will be invoked with clientData as argument when the + * application exits. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_DeleteThreadExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr, *prevPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { + if ((exitPtr->proc == proc) + && (exitPtr->clientData == clientData)) { + if (prevPtr == NULL) { + tsdPtr->firstExitPtr = exitPtr->nextPtr; + } else { + prevPtr->nextPtr = exitPtr->nextPtr; + } + ckfree((char *) exitPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Exit -- + * + * This procedure is called to terminate the application. + * + * Results: + * None. + * + * Side effects: + * All existing exit handlers are invoked, then the application + * ends. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_Exit(status) + int status; /* Exit status for application; typically + * 0 for normal return, 1 for error return. */ +{ + Tcl_Finalize(); + 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. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *toDupe; + int size; + + if (pathPtr != NULL) { + Tcl_IncrRefCount(pathPtr); + } + if (tsdPtr->tclLibraryPath != NULL) { + Tcl_DecrRefCount(tsdPtr->tclLibraryPath); + } + tsdPtr->tclLibraryPath = pathPtr; + + /* + * No mutex locking is needed here as up the stack we're within + * TclpInitLock(). + */ + if (tclLibraryPathStr != NULL) { + ckfree(tclLibraryPathStr); + } + toDupe = Tcl_GetStringFromObj(pathPtr, &size); + tclLibraryPathStr = ckalloc((unsigned)size+1); + memcpy(tclLibraryPathStr, toDupe, (unsigned)size+1); +} + +/* + *------------------------------------------------------------------------- + * + * 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() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->tclLibraryPath == NULL) { + /* + * Grab the shared string and place it into a new thread specific + * Tcl_Obj. + */ + tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1); + + /* take ownership */ + Tcl_IncrRefCount(tsdPtr->tclLibraryPath); + } + return tsdPtr->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(); /* process wide mutex init */ +#endif +#ifdef TCL_MEM_DEBUG + TclInitDbCkalloc(); /* process wide mutex init */ +#endif + + TclpInitPlatform(); /* creates signal handler(s) */ + TclInitObjSubsystem(); /* register obj types, create mutexes */ + TclInitIOSubsystem(); /* inits a tsd key (noop) */ + TclInitEncodingSubsystem(); /* process wide encoding init */ + TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */ + } + 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(); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Finalize -- + * + * Shut down Tcl. First calls registered exit handlers, then + * carefully shuts down various subsystems. + * Called by Tcl_Exit or when the Tcl shared library is being + * unloaded. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective finalization routines. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_Finalize() +{ + ExitHandler *exitPtr; + + /* + * Invoke exit handlers first. + */ + + Tcl_MutexLock(&exitMutex); + inFinalize = 1; + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { + /* + * Be careful to remove the handler from the list before + * invoking its callback. This protects us against + * double-freeing if the callback should call + * Tcl_DeleteExitHandler on itself. + */ + + firstExitPtr = exitPtr->nextPtr; + Tcl_MutexUnlock(&exitMutex); + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + Tcl_MutexLock(&exitMutex); + } + firstExitPtr = NULL; + Tcl_MutexUnlock(&exitMutex); + + TclpInitLock(); + if (subsystemsInitialized != 0) { + subsystemsInitialized = 0; + + /* + * Ensure the thread-specific data is initialised as it is + * used in Tcl_FinalizeThread() + */ + + (void) TCL_TSD_INIT(&dataKey); + + /* + * Clean up after the current thread now, after exit handlers. + * In particular, the testexithandler command sets up something + * that writes to standard output, which gets closed. + * Note that there is no thread-local storage after this call. + */ + + Tcl_FinalizeThread(); + + /* + * Now finalize the Tcl execution environment. Note that this + * must be done after the exit handlers, because there are + * order dependencies. + */ + + TclFinalizeCompilation(); + TclFinalizeExecution(); + TclFinalizeEnvironment(); + + /* + * Finalizing the filesystem must come after anything which + * might conceivably interact with the 'Tcl_FS' API. + */ + + TclFinalizeFilesystem(); + + /* + * Undo all the Tcl_ObjType registrations, and reset the master list + * of free Tcl_Obj's. After this returns, no more Tcl_Obj's should + * be allocated or freed. + * + * Note in particular that TclFinalizeObjects() must follow + * TclFinalizeFilesystem() because TclFinalizeFilesystem free's + * the Tcl_Obj that holds the path of the current working directory. + */ + + TclFinalizeObjects(); + + /* + * We must be sure the encoding finalization doesn't need + * to examine the filesystem in any way. Since it only + * needs to clean up internal data structures, this is + * fine. + */ + TclFinalizeEncodingSubsystem(); + + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + if (tclNativeExecutableName != NULL) { + ckfree(tclNativeExecutableName); + tclNativeExecutableName = NULL; + } + if (tclDefaultEncodingDir != NULL) { + ckfree(tclDefaultEncodingDir); + tclDefaultEncodingDir = NULL; + } + if (tclLibraryPathStr != NULL) { + ckfree(tclLibraryPathStr); + tclLibraryPathStr = NULL; + } + + Tcl_SetPanicProc(NULL); + + /* + * 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. + */ + +#ifdef TCL_MEM_DEBUG + if ( firstExitPtr != NULL ) { + Tcl_Panic( "exit handlers were created during Tcl_Finalize" ); + } +#endif + + TclFinalizePreserve(); + + /* + * Free synchronization objects. There really should only be one + * thread alive at this moment. + */ + + TclFinalizeSynchronization(); + +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG) && !defined(PURIFY) + TclFinalizeThreadAlloc(); +#endif + + /* + * We defer unloading of packages until very late + * to avoid memory access issues. Both exit callbacks and + * synchronization variables may be stored in packages. + * + * Note that TclFinalizeLoad unloads packages in the reverse + * of the order they were loaded in (i.e. last to be loaded + * is the first to be unloaded). This can be important for + * correct unloading when dependencies exist. + * + * Once load has been finalized, we will have deleted any + * temporary copies of shared libraries and can therefore + * reset the filesystem to its original state. + */ + + TclFinalizeLoad(); + TclResetFilesystem(); + + /* + * At this point, there should no longer be any ckalloc'ed memory. + */ + + TclFinalizeMemorySubsystem(); + inFinalize = 0; + } + TclFinalizeLock(); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeThread -- + * + * Runs the exit handlers to allow Tcl to clean up its state + * about a particular thread. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective finalization routines. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C void +Tcl_FinalizeThread() +{ + ExitHandler *exitPtr; + ThreadSpecificData *tsdPtr; + + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + if (tsdPtr != NULL) { + tsdPtr->inExit = 1; + + /* + * Clean up the library path now, before we invalidate thread-local + * storage or calling thread exit handlers. + */ + + if (tsdPtr->tclLibraryPath != NULL) { + Tcl_DecrRefCount(tsdPtr->tclLibraryPath); + tsdPtr->tclLibraryPath = NULL; + } + + for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; + exitPtr = tsdPtr->firstExitPtr) { + /* + * Be careful to remove the handler from the list before invoking + * its callback. This protects us against double-freeing if the + * callback should call Tcl_DeleteThreadExitHandler on itself. + */ + + tsdPtr->firstExitPtr = exitPtr->nextPtr; + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + } + TclFinalizeIOSubsystem(); + TclFinalizeNotifier(); + TclFinalizeAsync(); + } + + /* + * Blow away all thread local storage blocks. + * + * Note that Tcl API allows creation of threads which do not use any + * Tcl interp or other Tcl subsytems. Those threads might, however, + * use thread local storage, so we must unconditionally finalize it. + * + * Fix [Bug #571002] + */ + + TclFinalizeThreadData(); +} + +/* + *---------------------------------------------------------------------- + * + * TclInExit -- + * + * Determines if we are in the middle of exit-time cleanup. + * + * Results: + * If we are in the middle of exiting, 1, otherwise 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclInExit() +{ + return inFinalize; +} + +/* + *---------------------------------------------------------------------- + * + * TclInThreadExit -- + * + * Determines if we are in the middle of thread exit-time cleanup. + * + * Results: + * If we are in the middle of exiting this thread, 1, otherwise 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclInThreadExit() +{ + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); + if (tsdPtr == NULL) { + return 0; + } else { + return tsdPtr->inExit; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VwaitObjCmd -- + * + * This procedure is invoked to process the "vwait" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_VwaitObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int done, foundEvent; + char *nameString; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + nameString = Tcl_GetString(objv[1]); + if (Tcl_TraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + }; + done = 0; + foundEvent = 1; + while (!done && foundEvent) { + foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + if (!foundEvent) { + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, + "\": would wait forever", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /* ARGSUSED */ +static char * +VwaitVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST char *name1; /* Name of variable. */ + CONST char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateObjCmd -- + * + * This procedure is invoked to process the "update" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UpdateObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int optionIndex; + int flags = 0; /* Initialized to avoid compiler warning. */ + static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; + enum updateOptions {REGEXP_IDLETASKS}; + + if (objc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: { + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + } + default: { + panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); + } + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); + return TCL_ERROR; + } + + while (Tcl_DoOneEvent(flags) != 0) { + /* Empty loop body */ + } + + /* + * Must clear the interpreter's result because event handlers could + * have executed commands. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + +#ifdef TCL_THREADS +/* + *----------------------------------------------------------------------------- + * + * NewThreadProc -- + * + * Bootstrap function of a new Tcl thread. + * + * Results: + * None. + * + * Side Effects: + * Initializes Tcl notifier for the current thread. + * + *----------------------------------------------------------------------------- + */ + +static Tcl_ThreadCreateType +NewThreadProc(ClientData clientData) +{ + ThreadClientData *cdPtr; + ClientData threadClientData; + Tcl_ThreadCreateProc *threadProc; + + cdPtr = (ThreadClientData*)clientData; + threadProc = cdPtr->proc; + threadClientData = cdPtr->clientData; + ckfree((char*)clientData); /* Allocated in Tcl_CreateThread() */ + + (*threadProc)(threadClientData); + + TCL_THREAD_CREATE_RETURN; +} +#endif +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateThread -- + * + * This procedure creates a new thread. This actually belongs + * to the tclThread.c file but since we use some private + * data structures local to this file, it is placed here. + * + * Results: + * TCL_OK if the thread could be created. The thread ID is + * returned in a parameter. + * + * Side effects: + * A new thread is created. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C int +Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) + Tcl_ThreadId *idPtr; /* Return, the ID of the thread */ + Tcl_ThreadCreateProc proc; /* Main() function of the thread */ + ClientData clientData; /* The one argument to Main() */ + int stackSize; /* Size of stack for the new thread */ + int flags; /* Flags controlling behaviour of + * the new thread */ +{ +#ifdef TCL_THREADS + ThreadClientData *cdPtr; + + cdPtr = (ThreadClientData*)ckalloc(sizeof(ThreadClientData)); + cdPtr->proc = proc; + cdPtr->clientData = clientData; + + return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr, + stackSize, flags); +#else + return TCL_ERROR; +#endif /* TCL_THREADS */ +}