tclEvent.c Go to the documentation of this file. /* * 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. * * RCS: @(#) $Id: tclEvent.c,v 1.78 2007/12/13 15:23:16 dgp Exp $ */ #include "tclInt.h" /* * The data structure below is used to report background errors. One such * structure is allocated for each error; it holds information about the * interpreter and the error until an idle handler command can be invoked. */ typedef struct BgError { Tcl_Obj *errorMsg; /* Copy of the error message (the interp's * result when the error occurred). */ Tcl_Obj *returnOpts; /* Active return options when the error * occurred */ struct BgError *nextPtr; /* Next in list of all pending error reports * for this interpreter, or NULL for end of * list. */ } BgError; /* * One of the structures below is associated with the "tclBgError" assoc data * for each interpreter. It keeps track of the head and tail of the list of * pending background errors for the interpreter. */ typedef struct ErrAssocData { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors * waiting to be processed for this * interpreter (NULL if none). */ BgError *lastBgPtr; /* Last in list of all background errors * waiting to be processed for this * interpreter (NULL if none). */ } ErrAssocData; /* * For each exit handler created with a call to Tcl_CreateExitHandler there is * a structure of the following type: */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* 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. */ TCL_DECLARE_MUTEX(exitMutex) /* * This variable is set to 1 when Tcl_Finalize is called, and at the end of * its work, it is reset to 0. The variable is checked by TclInExit() to allow * different behavior for exit-time processing, e.g. in closing of files and * pipes. */ static int inFinalize = 0; static int subsystemsInitialized = 0; /* * This variable contains the application wide exit handler. It will be * called by Tcl_Exit instead of the C-runtime exit if this variable is set * to a non-NULL value. */ static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this * thread. */ int inExit; /* True when this thread is exiting. This is * used as a hack to decide to close the * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #ifdef TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ } ThreadClientData; static Tcl_ThreadCreateType NewThreadProc(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);  /* *---------------------------------------------------------------------- * * 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. */ { TclBackgroundException(interp, TCL_ERROR); } void TclBackgroundException( 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 = (BgError *) 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 = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr->firstBgPtr == NULL) { assocPtr->firstBgPtr = errPtr; Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); } else { assocPtr->lastBgPtr->nextPtr = errPtr; } assocPtr->lastBgPtr = errPtr; Tcl_ResetResult(interp); }  /* *---------------------------------------------------------------------- * * HandleBgErrors -- * * This 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 = (ErrAssocData *) clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; /* * Not bothering to save/restore the interp state. Assume that any code * that has interp state it needs to keep will make its own * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent() * that could lead us here. */ Tcl_Preserve((ClientData) assocPtr); Tcl_Preserve((ClientData) interp); while (assocPtr->firstBgPtr != NULL) { int code, prefixObjc; Tcl_Obj **prefixObjv, **tempObjv; /* * 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 = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL); /* * Discard the command and the information about the error report. */ Tcl_DecrRefCount(copyObj); Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); assocPtr->firstBgPtr = errPtr->nextPtr; ckfree((char *) errPtr); ckfree((char *) 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((char *) errPtr); } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; 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); } } } assocPtr->lastBgPtr = NULL; Tcl_Release((ClientData) interp); Tcl_Release((ClientData) assocPtr); }  /* *---------------------------------------------------------------------- * * 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 code, level; Tcl_InterpState saved; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "msg options"); return TCL_ERROR; } /* 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. */ TclNewLiteralStringObj(keyPtr, "-level"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); Tcl_GetIntFromObj(NULL, valuePtr, &level); if (level != 0) { /* We're handling a TCL_RETURN exception */ code = TCL_RETURN; } else { TclNewLiteralStringObj(keyPtr, "-code"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); Tcl_GetIntFromObj(NULL, valuePtr, &code); } switch (code) { case TCL_ERROR: tempObjv[1] = objv[1]; break; case TCL_BREAK: TclNewLiteralStringObj(tempObjv[1], "invoked \"break\" outside of a loop"); break; case TCL_CONTINUE: TclNewLiteralStringObj(tempObjv[1], "invoked \"continue\" outside of a loop"); break; default: tempObjv[1] = Tcl_ObjPrintf("command returned bad code: %d", code); break; } Tcl_IncrRefCount(tempObjv[1]); if (code != TCL_ERROR) { Tcl_SetObjResult(interp, tempObjv[1]); } TclNewLiteralStringObj(keyPtr, "-errorcode"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_SetObjErrorCode(interp, valuePtr); } TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_IncrRefCount(valuePtr); 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 != (Tcl_Channel) 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; }  /* *---------------------------------------------------------------------- * * 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 = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); if (cmdPrefix == NULL) { Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument"); } if (assocPtr == NULL) { /* * First access: initialize. */ assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; assocPtr->lastBgPtr = NULL; Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, (ClientData) assocPtr); } if (assocPtr->cmdPrefix) { Tcl_DecrRefCount(assocPtr->cmdPrefix); } assocPtr->cmdPrefix = cmdPrefix; Tcl_IncrRefCount(assocPtr->cmdPrefix); }  /* *---------------------------------------------------------------------- * * TclGetBgErrorHandler -- * * This 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 = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr == NULL) { Tcl_Obj *bgerrorObj; TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror"); TclSetBgErrorHandler(interp, bgerrorObj); assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); } return assocPtr->cmdPrefix; }  /* *---------------------------------------------------------------------- * * 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 cancelled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( ClientData clientData, /* Pointer to ErrAssocData structure. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { ErrAssocData *assocPtr = (ErrAssocData *) clientData; BgError *errPtr; while (assocPtr->firstBgPtr != NULL) { errPtr = assocPtr->firstBgPtr; assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); ckfree((char *) errPtr); } Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); Tcl_DecrRefCount(assocPtr->cmdPrefix); Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC); }  /* *---------------------------------------------------------------------- * * Tcl_CreateExitHandler -- * * Arrange for a given 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; 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 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 cancelled; 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((char *) exitPtr); break; } } Tcl_MutexUnlock(&exitMutex); return; }  /* *---------------------------------------------------------------------- * * 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 = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; tsdPtr->firstExitPtr = exitPtr; }  /* *---------------------------------------------------------------------- * * 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 cancelled; 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((char *) exitPtr); return; } } }  /* *---------------------------------------------------------------------- * * 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_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; /* * Swap the old exit proc for the new one, saving the old one for our * return value. */ Tcl_MutexLock(&exitMutex); prevExitProc = appExitPtr; appExitPtr = proc; Tcl_MutexUnlock(&exitMutex); return prevExitProc; }  /* *---------------------------------------------------------------------- * * Tcl_Exit -- * * This function is called to terminate the application. * * Results: * None. * * Side effects: * All existing exit handlers are invoked, then the application ends. * *---------------------------------------------------------------------- */ void Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; Tcl_MutexUnlock(&exitMutex); if (currentAppExitPtr) { /* * Warning: this code SHOULD NOT return, as there is code that depends * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone * returns, so critical is this dependcy. */ currentAppExitPtr((ClientData) INT2PTR(status)); Tcl_Panic("AppExitProc returned unexpectedly"); } else { /* * Use default handling. */ Tcl_Finalize(); TclpExit(status); Tcl_Panic("OS exit failed!"); } }  /* *------------------------------------------------------------------------- * * TclInitSubsystems -- * * Initialize various subsytems in Tcl. This should be called the first * time an interp is created, or before any of the subsystems are used. * This function ensures an order for the initialization of subsystems: * * 1. that cannot be initialized in lazy order because they are mutually * dependent. * * 2. so that they can be finalized in a known order w/o causing the * subsequent re-initialization of a subsystem in the act of shutting * down another. * * Results: * None. * * Side effects: * Varied, see the respective initialization routines. * *------------------------------------------------------------------------- */ void TclInitSubsystems(void) { if (inFinalize != 0) { Tcl_Panic("TclInitSubsystems called while finalizing"); } if (subsystemsInitialized == 0) { /* * Double check inside the mutex. There are definitly calls back into * this routine from some of the functions below. */ TclpInitLock(); if (subsystemsInitialized == 0) { /* * Have to set this bit here to avoid deadlock with the routines * below us that call into TclInitSubsystems. */ subsystemsInitialized = 1; /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ #if 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. */ TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ } TclpInitUnlock(); } TclInitNotifier(); }  /* *---------------------------------------------------------------------- * * Tcl_Finalize -- * * Shut down Tcl. First calls registered exit handlers, then carefully * shuts down various subsystems. Called by Tcl_Exit or when the Tcl * shared library is being unloaded. * * Results: * None. * * Side effects: * Varied, see the respective finalization routines. * *---------------------------------------------------------------------- */ void Tcl_Finalize(void) { 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) { 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 finalize the Tcl execution environment. Note that this must be done * after the exit handlers, because there are order dependencies. */ 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 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(); Tcl_SetPanicProc(NULL); /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series * of events happening afterwards may re-initialize TSD slots. Those need * to be finalized again, otherwise we're leaking memory chunks. Very * important to note is that things happening afterwards should not * reference anything which may re-initialize TSD's. This includes freeing * Tcl_Objs's, among other things. * * This fixes the Tcl Bug #990552. */ TclFinalizeThreadData(); /* * 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_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. */ 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(); inFinalize = 0; alreadyFinalized: TclFinalizeLock(); }  /* *---------------------------------------------------------------------- * * Tcl_FinalizeThread -- * * Runs the exit handlers to allow Tcl to clean up its state about a * particular thread. * * Results: * None. * * Side effects: * Varied, see the respective finalization routines. * *---------------------------------------------------------------------- */ void Tcl_FinalizeThread(void) { 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 = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL) { tsdPtr->inExit = 1; for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; exitPtr = tsdPtr->firstExitPtr) { /* * Be careful to remove the handler from the list before invoking * its callback. This protects us against double-freeing if the * callback should call Tcl_DeleteThreadExitHandler on itself. */ tsdPtr->firstExitPtr = exitPtr->nextPtr; (*exitPtr->proc)(exitPtr->clientData); ckfree((char *) exitPtr); } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); TclFinalizeAsync(); } /* * Blow away all thread local storage blocks. * * Note that Tcl API allows creation of threads which do not use any Tcl * interp or other Tcl subsytems. Those threads might, however, use thread * local storage, so we must unconditionally finalize it. * * Fix [Bug #571002] */ TclFinalizeThreadData(); }  /* *---------------------------------------------------------------------- * * TclInExit -- * * Determines if we are in the middle of exit-time cleanup. * * Results: * If we are in the middle of exiting, 1, otherwise 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclInExit(void) { 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(void) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { return 0; } else { return tsdPtr->inExit; } }  /* *---------------------------------------------------------------------- * * 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; char *nameString; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } nameString = Tcl_GetString(objv[1]); if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done) != TCL_OK) { return TCL_ERROR; }; done = 0; foundEvent = 1; while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); if (Tcl_LimitExceeded(interp)) { break; } } 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", NULL); return TCL_ERROR; } if (!done) { Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } 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 = (int *) clientData; *donePtr = 1; return NULL; }  /* *---------------------------------------------------------------------- * * 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 *updateOptions[] = {"idletasks", NULL}; enum updateOptions {REGEXP_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (objc == 2) { if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { case REGEXP_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); } } else { Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } while (Tcl_DoOneEvent(flags) != 0) { if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } } /* * Must clear the interpreter's result because event handlers could have * executed commands. */ Tcl_ResetResult(interp); return TCL_OK; }  #ifdef TCL_THREADS /* *----------------------------------------------------------------------------- * * NewThreadProc -- * * Bootstrap function of a new Tcl thread. * * Results: * None. * * Side Effects: * Initializes Tcl notifier for the current thread. * *----------------------------------------------------------------------------- */ static Tcl_ThreadCreateType NewThreadProc( ClientData clientData) { ThreadClientData *cdPtr; ClientData threadClientData; Tcl_ThreadCreateProc *threadProc; cdPtr = (ThreadClientData *) clientData; threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */ (*threadProc)(threadClientData); TCL_THREAD_CREATE_RETURN; } #endif  /* *---------------------------------------------------------------------- * * 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; 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 */ }  /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */

• ソフトウェア開発
• ホームページ制作
• Doxygen版
• STLport版