diff options
Diffstat (limited to 'generic/tclEvent.c')
| -rw-r--r-- | generic/tclEvent.c | 561 |
1 files changed, 450 insertions, 111 deletions
diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 4672982..e7ed511 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. * - * SCCS: @(#) tclEvent.c 1.153 97/08/11 20:22:31 + * SCCS: @(#) tclEvent.c 1.173 98/02/18 18:23:41 */ #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,37 @@ 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. */ +static Tcl_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 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 +138,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 +150,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 +218,6 @@ HandleBgErrors(clientData) ClientData clientData; /* Pointer to ErrAssocData structure. */ { Tcl_Interp *interp; - char *command; char *argv[2]; int code; BgError *errPtr; @@ -237,11 +248,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 +266,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 +282,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 +410,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 +442,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 +452,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 +557,168 @@ 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. + */ +#ifdef USE_TCLALLOC + TclInitAlloc(); #endif - TclPlatformExit(status); +#ifdef TCL_MEM_DEBUG + TclInitDbCkalloc(); +#endif + + TclpInitPlatform(); + + TclInitObjSubsystem(); + TclInitIOSubsystem(); + TclInitEncodingSubsystem(); + + TclpInitLibraryPath(argv0); + TclpSetInitialEncodings(); + + 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(); + } } /* @@ -497,16 +726,15 @@ 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. + * Runs the exit handlers to allow Tcl to clean up its state. + * 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,33 +743,133 @@ void Tcl_Finalize() { ExitHandler *exitPtr; + + + TclpInitLock(); + if (subsystemsInitialized != 0) { + subsystemsInitialized = 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; + } + Tcl_SetPanicProc(NULL); + + /* + * Free synchronization objects. There really should only be one + * thread alive at this moment. + */ + + TclFinalizeSynchronization(); - 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(); - 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(); + } } /* @@ -563,13 +891,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. @@ -585,20 +914,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; @@ -608,7 +938,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); @@ -619,7 +949,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; } @@ -644,7 +974,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. @@ -660,29 +990,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 */ } |