diff options
Diffstat (limited to 'generic/tclEvent.c')
| -rw-r--r-- | generic/tclEvent.c | 1035 |
1 files changed, 234 insertions, 801 deletions
diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 1a2f8ca..c664b38 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -5,16 +5,15 @@ * background errors, exit handlers, and the "vwait" and "update" command * functions. * - * Copyright © 1990-1994 The Regents of the University of California. - * Copyright © 1994-1998 Sun Microsystems, Inc. - * Copyright © 2004 Zoran Vasiljevic. + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright (c) 2004 by Zoran Vasiljevic. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclUuid.h" /* * The data structure below is used to report background errors. One such @@ -38,7 +37,7 @@ typedef struct BgError { * pending background errors for the interpreter. */ -typedef struct { +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 @@ -50,26 +49,13 @@ typedef struct { } ErrAssocData; /* - * For each "vwait" event source a structure of the following type - * is used: - */ - -typedef struct { - int *donePtr; /* Pointer to flag to signal or NULL. */ - int sequence; /* Order of occurrence. */ - int mask; /* 0, or TCL_READABLE/TCL_WRITABLE. */ - Tcl_Obj *sourceObj; /* Name of the event source, either a - * variable name or channel name. */ -} VwaitItem; - -/* - * For each exit handler created with a call to Tcl_Create(Late)ExitHandler - * there is a structure of the following type: + * For each exit handler created with a call to Tcl_Create(Late)ExitHandler there is + * a structure of the following type: */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* Function to call when process exits. */ - void *clientData; /* One word of information to pass to proc. */ + 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; @@ -88,24 +74,22 @@ static ExitHandler *firstLateExitPtr = NULL; TCL_DECLARE_MUTEX(exitMutex) /* - * This variable is set to 1 when Tcl_Exit is called. The variable is checked - * by TclInExit() to allow different behavior for exit-time processing, e.g., - * in closing of files and pipes. + * 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 inExit = 0; - +static int inFinalize = 0; static int subsystemsInitialized = 0; -static const char ENCODING_ERROR[] = "\n\t(encoding error in stderr)"; - /* - * 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. + * This variable contains the application wide exit handler. It will be + * called by Tcl_Exit instead of the C-runtime exit if this variable is set + * to a non-NULL value. */ -static TCL_NORETURN1 Tcl_ExitProc *appExitPtr = NULL; +static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this @@ -116,29 +100,23 @@ typedef struct ThreadSpecificData { } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#if TCL_THREADS +#ifdef TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ - void *clientData; /* The one argument to Main() */ + ClientData clientData; /* The one argument to Main() */ } ThreadClientData; -static Tcl_ThreadCreateType NewThreadProc(void *clientData); +static Tcl_ThreadCreateType NewThreadProc(ClientData clientData); #endif /* TCL_THREADS */ /* * Prototypes for functions referenced only in this file: */ -static void BgErrorDeleteProc(void *clientData, +static void BgErrorDeleteProc(ClientData clientData, Tcl_Interp *interp); -static void HandleBgErrors(void *clientData); -static void VwaitChannelReadProc(void *clientData, int mask); -static void VwaitChannelWriteProc(void *clientData, int mask); -static void VwaitTimeoutProc(void *clientData); -static char * VwaitVarProc(void *clientData, - Tcl_Interp *interp, const char *name1, - const char *name2, int flags); -static void InvokeExitHandlers(void); -static void FinalizeThread(int quick); +static void HandleBgErrors(ClientData clientData); +static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags); /* *---------------------------------------------------------------------- @@ -158,19 +136,15 @@ static void FinalizeThread(int quick); *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 -#undef Tcl_BackgroundError void Tcl_BackgroundError( Tcl_Interp *interp) /* Interpreter in which an error has * occurred. */ { - Tcl_BackgroundException(interp, TCL_ERROR); + TclBackgroundException(interp, TCL_ERROR); } -#endif /* TCL_NO_DEPRECATED */ - void -Tcl_BackgroundException( +TclBackgroundException( Tcl_Interp *interp, /* Interpreter in which an exception has * occurred. */ int code) /* The exception code value */ @@ -182,7 +156,7 @@ Tcl_BackgroundException( return; } - errPtr = (BgError*)ckalloc(sizeof(BgError)); + errPtr = (BgError *) ckalloc(sizeof(BgError)); errPtr->errorMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errPtr->errorMsg); errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); @@ -190,10 +164,10 @@ Tcl_BackgroundException( errPtr->nextPtr = NULL; (void) TclGetBgErrorHandler(interp); - assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr->firstBgPtr == NULL) { assocPtr->firstBgPtr = errPtr; - Tcl_DoWhenIdle(HandleBgErrors, assocPtr); + Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); } else { assocPtr->lastBgPtr->nextPtr = errPtr; } @@ -220,9 +194,9 @@ Tcl_BackgroundException( static void HandleBgErrors( - void *clientData) /* Pointer to ErrAssocData structure. */ + ClientData clientData) /* Pointer to ErrAssocData structure. */ { - ErrAssocData *assocPtr = (ErrAssocData *)clientData; + ErrAssocData *assocPtr = (ErrAssocData *) clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; @@ -233,24 +207,23 @@ HandleBgErrors( * that could lead us here. */ - Tcl_Preserve(assocPtr); - Tcl_Preserve(interp); + Tcl_Preserve((ClientData) assocPtr); + Tcl_Preserve((ClientData) interp); while (assocPtr->firstBgPtr != NULL) { - int code; - Tcl_Size prefixObjc; + 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. + * 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; - TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); - tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); + 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; @@ -265,8 +238,8 @@ HandleBgErrors( Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); assocPtr->firstBgPtr = errPtr->nextPtr; - ckfree(errPtr); - ckfree(tempObjv); + ckfree((char *) errPtr); + ckfree((char *) tempObjv); if (code == TCL_BREAK) { /* @@ -279,12 +252,12 @@ HandleBgErrors( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - ckfree(errPtr); + ckfree((char *) errPtr); } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel != NULL) { + if (errChannel != (Tcl_Channel) NULL) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr = NULL; @@ -296,13 +269,9 @@ HandleBgErrors( Tcl_WriteChars(errChannel, "error in background error handler:\n", -1); if (valuePtr) { - if (Tcl_WriteObj(errChannel, valuePtr) < 0) { - Tcl_WriteChars(errChannel, ENCODING_ERROR, -1); - } + Tcl_WriteObj(errChannel, valuePtr); } else { - if (Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)) < 0) { - Tcl_WriteChars(errChannel, ENCODING_ERROR, -1); - } + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); } Tcl_WriteChars(errChannel, "\n", 1); Tcl_Flush(errChannel); @@ -311,8 +280,8 @@ HandleBgErrors( } } assocPtr->lastBgPtr = NULL; - Tcl_Release(interp); - Tcl_Release(assocPtr); + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) assocPtr); } /* @@ -335,10 +304,10 @@ HandleBgErrors( int TclDefaultBgErrorHandlerObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; @@ -361,7 +330,6 @@ TclDefaultBgErrorHandlerObjCmd( if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { @@ -374,7 +342,6 @@ TclDefaultBgErrorHandlerObjCmd( if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { @@ -382,26 +349,19 @@ TclDefaultBgErrorHandlerObjCmd( } if (level != 0) { - /* - * We're handling a TCL_RETURN exception. - */ - + /* We're handling a TCL_RETURN exception */ code = TCL_RETURN; } if (code == TCL_OK) { /* - * Somehow we got to exception handling with no exception. (Pass - * TCL_OK to Tcl_BackgroundException()?) Just return without doing - * anything. + * Somehow we got to exception handling with no exception. + * (Pass TCL_OK to TclBackgroundException()?) + * Just return without doing anything. */ - return TCL_OK; } - /* - * Construct the bgerror command. - */ - + /* Construct the bgerror command */ TclNewLiteralStringObj(tempObjv[0], "bgerror"); Tcl_IncrRefCount(tempObjv[0]); @@ -459,10 +419,7 @@ TclDefaultBgErrorHandlerObjCmd( saved = Tcl_SaveInterpState(interp, code); - /* - * Invoke the bgerror command. - */ - + /* Invoke the bgerror command. */ Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL); if (code == TCL_ERROR) { @@ -481,30 +438,25 @@ TclDefaultBgErrorHandlerObjCmd( TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN); } else { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); - - if (errChannel != NULL) { + 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); - if (Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, - "errorInfo", NULL, TCL_GLOBAL_ONLY)) < 0) { - Tcl_WriteChars(errChannel, ENCODING_ERROR, -1); - } + 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 Original error: ", -1); - if (Tcl_WriteObj(errChannel, tempObjv[1]) < 0) { - Tcl_WriteChars(errChannel, ENCODING_ERROR, -1); - } - Tcl_WriteChars(errChannel, "\n Error in bgerror: ", -1); - if (Tcl_WriteObj(errChannel, resultPtr) < 0) { - Tcl_WriteChars(errChannel, ENCODING_ERROR, -1); - } + 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); @@ -546,7 +498,8 @@ TclSetBgErrorHandler( Tcl_Interp *interp, Tcl_Obj *cmdPrefix) { - ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + ErrAssocData *assocPtr = (ErrAssocData *) + Tcl_GetAssocData(interp, "tclBgError", NULL); if (cmdPrefix == NULL) { Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument"); @@ -556,12 +509,13 @@ TclSetBgErrorHandler( * First access: initialize. */ - assocPtr = (ErrAssocData*)ckalloc(sizeof(ErrAssocData)); + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; assocPtr->lastBgPtr = NULL; - Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr); + Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, + (ClientData) assocPtr); } if (assocPtr->cmdPrefix) { Tcl_DecrRefCount(assocPtr->cmdPrefix); @@ -591,14 +545,16 @@ Tcl_Obj * TclGetBgErrorHandler( Tcl_Interp *interp) { - ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + 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); + assocPtr = (ErrAssocData *) + Tcl_GetAssocData(interp, "tclBgError", NULL); } return assocPtr->cmdPrefix; } @@ -610,24 +566,24 @@ TclGetBgErrorHandler( * * 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 associated with any pending error reports. + * free the information assoicated with any pending error reports. * * Results: * None. * * Side effects: * Background error information is freed: if there were any pending error - * reports, they are canceled. + * reports, they are cancelled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( - void *clientData, /* Pointer to ErrAssocData structure. */ - TCL_UNUSED(Tcl_Interp *)) + ClientData clientData, /* Pointer to ErrAssocData structure. */ + Tcl_Interp *interp) /* Interpreter being deleted. */ { - ErrAssocData *assocPtr = (ErrAssocData *)clientData; + ErrAssocData *assocPtr = (ErrAssocData *) clientData; BgError *errPtr; while (assocPtr->firstBgPtr != NULL) { @@ -635,11 +591,11 @@ BgErrorDeleteProc( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - ckfree(errPtr); + ckfree((char *) errPtr); } - Tcl_CancelIdleCall(HandleBgErrors, assocPtr); + Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); Tcl_DecrRefCount(assocPtr->cmdPrefix); - Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC); } /* @@ -663,10 +619,11 @@ BgErrorDeleteProc( void Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr; + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); @@ -680,8 +637,7 @@ Tcl_CreateExitHandler( * * TclCreateLateExitHandler -- * - * Arrange for a given function to be invoked after all pre-thread - * cleanups. + * Arrange for a given function to be invoked after all pre-thread cleanups * * Results: * None. @@ -696,10 +652,11 @@ Tcl_CreateExitHandler( void TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr; + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; Tcl_MutexLock(&exitMutex); @@ -721,7 +678,7 @@ TclCreateLateExitHandler( * * Side effects: * If there is an exit handler corresponding to proc and clientData then - * it is canceled; if no such handler exists then nothing happens. + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ @@ -729,7 +686,7 @@ TclCreateLateExitHandler( void Tcl_DeleteExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; @@ -743,7 +700,7 @@ Tcl_DeleteExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree(exitPtr); + ckfree((char *) exitPtr); break; } } @@ -763,8 +720,8 @@ Tcl_DeleteExitHandler( * None. * * Side effects: - * If there is a late exit handler corresponding to proc and clientData - * then it is canceled; if no such handler exists then nothing happens. + * If there is a late exit handler corresponding to proc and clientData then + * it is canceled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ @@ -772,7 +729,7 @@ Tcl_DeleteExitHandler( void TclDeleteLateExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; @@ -786,7 +743,7 @@ TclDeleteLateExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree(exitPtr); + ckfree((char *) exitPtr); break; } } @@ -815,12 +772,12 @@ TclDeleteLateExitHandler( void Tcl_CreateThreadExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; @@ -840,7 +797,7 @@ Tcl_CreateThreadExitHandler( * * Side effects: * If there is an exit handler corresponding to proc and clientData then - * it is canceled; if no such handler exists then nothing happens. + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ @@ -848,7 +805,7 @@ Tcl_CreateThreadExitHandler( void Tcl_DeleteThreadExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -862,7 +819,7 @@ Tcl_DeleteThreadExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - ckfree(exitPtr); + ckfree((char *) exitPtr); return; } } @@ -888,7 +845,7 @@ Tcl_DeleteThreadExitHandler( Tcl_ExitProc * Tcl_SetExitProc( - TCL_NORETURN1 Tcl_ExitProc *proc) /* New exit handler for app or NULL */ + Tcl_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; @@ -904,49 +861,6 @@ Tcl_SetExitProc( return prevExitProc; } - - -/* - *---------------------------------------------------------------------- - * - * InvokeExitHandlers -- - * - * Call the registered exit handlers. - * - * Results: - * None. - * - * Side effects: - * The exit handlers are invoked, and the ExitHandler struct is - * freed. - * - *---------------------------------------------------------------------- - */ -static void -InvokeExitHandlers(void) -{ - ExitHandler *exitPtr; - - Tcl_MutexLock(&exitMutex); - inExit = 1; - - for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { - /* - * Be careful to remove the handler from the list before invoking its - * callback. This protects us against double-freeing if the callback - * should call Tcl_DeleteExitHandler on itself. - */ - - firstExitPtr = exitPtr->nextPtr; - Tcl_MutexUnlock(&exitMutex); - exitPtr->proc(exitPtr->clientData); - ckfree(exitPtr); - Tcl_MutexLock(&exitMutex); - } - firstExitPtr = NULL; - Tcl_MutexUnlock(&exitMutex); -} - /* *---------------------------------------------------------------------- @@ -964,73 +878,41 @@ InvokeExitHandlers(void) *---------------------------------------------------------------------- */ -TCL_NORETURN void +void Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { - TCL_NORETURN1 Tcl_ExitProc *currentAppExitPtr; + Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; Tcl_MutexUnlock(&exitMutex); - /* - * Warning: this function SHOULD NOT return, as there is code that depends - * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone - * returns, so critical is this dependency. - * - * If subsystems are not (yet) initialized, proper Tcl-finalization is - * impossible, so fallback to system exit, see bug-[f8a33ce3db5d8cc2]. - */ - 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(INT2PTR(status)); - - } else if (subsystemsInitialized) { - - if (TclFullFinalizationRequested()) { - - /* - * Thorough finalization for Valgrind et al. - */ - - Tcl_Finalize(); - - } else { - - /* - * Fast and deterministic exit (default behavior) - */ - - InvokeExitHandlers(); - - /* - * Ensure the thread-specific data is initialised as it is used in - * Tcl_FinalizeThread() - */ - - (void) TCL_TSD_INIT(&dataKey); - - /* - * Now finalize the calling thread only (others are not safely - * reachable). Among other things, this triggers a flush of the - * Tcl_Channels that may have data enqueued. - */ + currentAppExitPtr((ClientData) INT2PTR(status)); + Tcl_Panic("AppExitProc returned unexpectedly"); + } else { + /* + * Use default handling. + */ - FinalizeThread(/* quick */ 1); - } + Tcl_Finalize(); + TclpExit(status); + Tcl_Panic("OS exit failed!"); } - - TclpExit(status); - Tcl_Panic("OS exit failed!"); } /* *------------------------------------------------------------------------- * - * Tcl_InitSubsystems -- + * 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. @@ -1044,7 +926,7 @@ Tcl_Exit( * down another. * * Results: - * The full Tcl version with build information. + * None. * * Side effects: * Varied, see the respective initialization routines. @@ -1052,95 +934,16 @@ Tcl_Exit( *------------------------------------------------------------------------- */ -MODULE_SCOPE const TclStubs tclStubs; - -#ifndef STRINGIFY -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -#endif - -static const struct { - const TclStubs *stubs; - const char version[256]; -} stubInfo = { - &tclStubs, {TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) -#if defined(__clang__) && defined(__clang_major__) - ".clang-" STRINGIFY(__clang_major__) -#if __clang_minor__ < 10 - "0" -#endif - STRINGIFY(__clang_minor__) -#endif -#ifdef TCL_COMPILE_DEBUG - ".compiledebug" -#endif -#ifdef TCL_COMPILE_STATS - ".compilestats" -#endif -#if defined(__cplusplus) && !defined(__OBJC__) - ".cplusplus" -#endif -#ifndef NDEBUG - ".debug" -#endif -#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__) - ".gcc-" STRINGIFY(__GNUC__) -#if __GNUC_MINOR__ < 10 - "0" -#endif - STRINGIFY(__GNUC_MINOR__) -#endif -#ifdef __INTEL_COMPILER - ".icc-" STRINGIFY(__INTEL_COMPILER) -#endif -#if (defined(_WIN32) || (ULONG_MAX == 0xffffffffUL)) && !defined(_WIN64) - ".ilp32" -#endif -#ifdef TCL_MEM_DEBUG - ".memdebug" -#endif -#if defined(_MSC_VER) - ".msvc-" STRINGIFY(_MSC_VER) -#endif -#ifdef USE_NMAKE - ".nmake" -#endif -#ifdef TCL_NO_DEPRECATED - ".no-deprecate" -#endif -#if !TCL_THREADS - ".no-thread" -#endif -#ifndef TCL_CFG_OPTIMIZED - ".no-optimize" -#endif -#ifdef __OBJC__ - ".objective-c" -#if defined(__cplusplus) - "plusplus" -#endif -#endif -#ifdef TCL_CFG_PROFILED - ".profile" -#endif -#ifdef PURIFY - ".purify" -#endif -#ifdef STATIC_BUILD - ".static" -#endif -}}; - -const char * -Tcl_InitSubsystems(void) +void +TclInitSubsystems(void) { - if (inExit != 0) { - Tcl_Panic("Tcl_InitSubsystems called while exiting"); + if (inFinalize != 0) { + Tcl_Panic("TclInitSubsystems called while finalizing"); } if (subsystemsInitialized == 0) { /* - * Double check inside the mutex. There are definitely calls back into + * Double check inside the mutex. There are definitly calls back into * this routine from some of the functions below. */ @@ -1153,14 +956,11 @@ Tcl_InitSubsystems(void) * implementation of self-initializing locks. */ - TclInitThreadStorage(); /* Creates hash table for + TclInitThreadStorage(); /* Creates master hash table for * thread local storage */ -#if defined(USE_TCLALLOC) && USE_TCLALLOC +#if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif -#if TCL_THREADS && defined(USE_THREAD_ALLOC) - TclInitThreadAlloc(); /* Setup thread allocator caches */ -#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif @@ -1172,13 +972,13 @@ Tcl_InitSubsystems(void) * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ + TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } TclpInitUnlock(); } TclInitNotifier(); - return stubInfo.version; } /* @@ -1187,8 +987,8 @@ Tcl_InitSubsystems(void) * Tcl_Finalize -- * * Shut down Tcl. First calls registered exit handlers, then carefully - * shuts down various subsystems. Should be invoked by user before the - * Tcl shared library is being unloaded in an embedded context. + * shuts down various subsystems. Called by Tcl_Exit or when the Tcl + * shared library is being unloaded. * * Results: * None. @@ -1208,7 +1008,23 @@ Tcl_Finalize(void) * Invoke exit handlers first. */ - InvokeExitHandlers(); + 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) { @@ -1237,8 +1053,7 @@ Tcl_Finalize(void) */ Tcl_MutexLock(&exitMutex); - for (exitPtr = firstLateExitPtr; exitPtr != NULL; - exitPtr = firstLateExitPtr) { + for (exitPtr = firstLateExitPtr; exitPtr != NULL; exitPtr = firstLateExitPtr) { /* * Be careful to remove the handler from the list before invoking its * callback. This protects us against double-freeing if the callback @@ -1248,7 +1063,7 @@ Tcl_Finalize(void) firstLateExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - ckfree(exitPtr); + ckfree((char *) exitPtr); Tcl_MutexLock(&exitMutex); } firstLateExitPtr = NULL; @@ -1259,7 +1074,6 @@ Tcl_Finalize(void) * after the exit handlers, because there are order dependencies. */ - TclFinalizeEvaluation(); TclFinalizeExecution(); TclFinalizeEnvironment(); @@ -1271,7 +1085,7 @@ Tcl_Finalize(void) TclFinalizeFilesystem(); /* - * Undo all Tcl_ObjType registrations, and reset the global list of free + * 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. * @@ -1290,6 +1104,8 @@ Tcl_Finalize(void) 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 @@ -1302,7 +1118,7 @@ Tcl_Finalize(void) * This fixes the Tcl Bug #990552. */ - TclFinalizeThreadData(/* quick */ 0); + TclFinalizeThreadData(); /* * Now we can free constants for conversions to/from double. @@ -1313,10 +1129,10 @@ Tcl_Finalize(void) /* * There have been several bugs in the past that cause exit handlers to be * established during Tcl_Finalize processing. Such exit handlers leave - * malloc'ed memory, and Tcl_FinalizeMemorySubsystem or - * Tcl_FinalizeThreadAlloc will result in a corrupted heap. The result can - * be a mysterious crash on process exit. Check here that nobody's done - * this. + * 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) { @@ -1336,7 +1152,7 @@ Tcl_Finalize(void) * Close down the thread-specific object allocator. */ -#if TCL_THREADS && defined(USE_THREAD_ALLOC) +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); #endif @@ -1363,6 +1179,7 @@ Tcl_Finalize(void) */ TclFinalizeMemorySubsystem(); + inFinalize = 0; alreadyFinalized: TclFinalizeLock(); @@ -1388,13 +1205,6 @@ Tcl_Finalize(void) void Tcl_FinalizeThread(void) { - FinalizeThread(/* quick */ 0); -} - -void -FinalizeThread( - int quick) -{ ExitHandler *exitPtr; ThreadSpecificData *tsdPtr; @@ -1404,7 +1214,7 @@ FinalizeThread( * initialized already. */ - tsdPtr = (ThreadSpecificData*)TclThreadDataKeyGet(&dataKey); + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL) { tsdPtr->inExit = 1; @@ -1417,8 +1227,8 @@ FinalizeThread( */ tsdPtr->firstExitPtr = exitPtr->nextPtr; - exitPtr->proc(exitPtr->clientData); - ckfree(exitPtr); + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); @@ -1435,7 +1245,8 @@ FinalizeThread( * * Fix [Bug #571002] */ - TclFinalizeThreadData(quick); + + TclFinalizeThreadData(); } /* @@ -1457,7 +1268,7 @@ FinalizeThread( int TclInExit(void) { - return inExit; + return inFinalize; } /* @@ -1479,12 +1290,13 @@ TclInExit(void) int TclInThreadExit(void) { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { return 0; + } else { + return tsdPtr->inExit; } - return tsdPtr->inExit; } /* @@ -1504,439 +1316,69 @@ TclInThreadExit(void) *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_VwaitObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - int i, done = 0, timedOut = 0, foundEvent, any = 1, timeout = 0; - int numItems = 0, extended = 0, result, mode, mask = TCL_ALL_EVENTS; - Tcl_InterpState saved = NULL; - Tcl_TimerToken timer = NULL; - Tcl_Time before, after; - Tcl_Channel chan; - Tcl_WideInt diff = -1; - VwaitItem localItems[32], *vwaitItems = localItems; - static const char *const vWaitOptionStrings[] = { - "-all", "-extended", "-nofileevents", "-noidleevents", - "-notimerevents", "-nowindowevents", "-readable", - "-timeout", "-variable", "-writable", "--", NULL - }; - enum vWaitOptions { - OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS, - OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE, - OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST - } index; - - if ((objc == 2) && (strcmp(TclGetString(objv[1]), "--") != 0)) { - /* - * Legacy "vwait" syntax, skip option handling. - */ - i = 1; - goto endOfOptionLoop; - } - - if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) { - vwaitItems = (VwaitItem *) ckalloc(sizeof(VwaitItem) * (objc - 1)); - } + int done, foundEvent; + char *nameString; - for (i = 1; i < objc; i++) { - const char *name; - - name = TclGetString(objv[i]); - if (name[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], vWaitOptionStrings, "option", 0, - &index) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - switch (index) { - case OPT_ALL: - any = 0; - break; - case OPT_EXTD: - extended = 1; - break; - case OPT_NO_FEVTS: - mask &= ~TCL_FILE_EVENTS; - break; - case OPT_NO_IEVTS: - mask &= ~TCL_IDLE_EVENTS; - break; - case OPT_NO_TEVTS: - mask &= ~TCL_TIMER_EVENTS; - break; - case OPT_NO_WEVTS: - mask &= ~TCL_WINDOW_EVENTS; - break; - case OPT_TIMEOUT: - if (++i >= objc) { - needArg: - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "argument required for \"%s\"", vWaitOptionStrings[index])); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", (void *)NULL); - result = TCL_ERROR; - goto done; - } - if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (timeout < 0) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "timeout must be positive", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", (void *)NULL); - result = TCL_ERROR; - goto done; - } - break; - case OPT_LAST: - i++; - goto endOfOptionLoop; - case OPT_VARIABLE: - if (++i >= objc) { - goto needArg; - } - result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, &vwaitItems[numItems]); - if (result != TCL_OK) { - goto done; - } - vwaitItems[numItems].donePtr = &done; - vwaitItems[numItems].sequence = -1; - vwaitItems[numItems].mask = 0; - vwaitItems[numItems].sourceObj = objv[i]; - numItems++; - break; - case OPT_READABLE: - if (++i >= objc) { - goto needArg; - } - if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0) - != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't open for reading", - TclGetString(objv[i]))); - result = TCL_ERROR; - goto done; - } - Tcl_CreateChannelHandler(chan, TCL_READABLE, - VwaitChannelReadProc, &vwaitItems[numItems]); - vwaitItems[numItems].donePtr = &done; - vwaitItems[numItems].sequence = -1; - vwaitItems[numItems].mask = TCL_READABLE; - vwaitItems[numItems].sourceObj = objv[i]; - numItems++; - break; - case OPT_WRITABLE: - if (++i >= objc) { - goto needArg; - } - if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0) - != TCL_OK) { - result = TCL_ERROR; - goto done; - } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't open for writing", - TclGetString(objv[i]))); - result = TCL_ERROR; - goto done; - } - Tcl_CreateChannelHandler(chan, TCL_WRITABLE, - VwaitChannelWriteProc, &vwaitItems[numItems]); - vwaitItems[numItems].donePtr = &done; - vwaitItems[numItems].sequence = -1; - vwaitItems[numItems].mask = TCL_WRITABLE; - vwaitItems[numItems].sourceObj = objv[i]; - numItems++; - break; - } - } - - endOfOptionLoop: - if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS | - TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't wait: would block forever", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (void *)NULL); - result = TCL_ERROR; - goto done; - } - - if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "timer events disabled with timeout specified", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", (void *)NULL); - result = TCL_ERROR; - goto done; - } - - for (result = TCL_OK; i < objc; i++) { - result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, &vwaitItems[numItems]); - if (result != TCL_OK) { - break; - } - vwaitItems[numItems].donePtr = &done; - vwaitItems[numItems].sequence = -1; - vwaitItems[numItems].mask = 0; - vwaitItems[numItems].sourceObj = objv[i]; - numItems++; - } - if (result != TCL_OK) { - result = TCL_ERROR; - goto done; - } - - if (!(mask & TCL_FILE_EVENTS)) { - for (i = 0; i < numItems; i++) { - if (vwaitItems[i].mask) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "file events disabled with channel(s) specified", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", (void *)NULL); - result = TCL_ERROR; - goto done; - } - } - } - - if (timeout > 0) { - vwaitItems[numItems].donePtr = &timedOut; - vwaitItems[numItems].sequence = -1; - vwaitItems[numItems].mask = 0; - vwaitItems[numItems].sourceObj = NULL; - timer = Tcl_CreateTimerHandler(timeout, VwaitTimeoutProc, - &vwaitItems[numItems]); - Tcl_GetTime(&before); - } else { - timeout = 0; - } - - if ((numItems == 0) && (timeout == 0)) { - /* - * "vwait" is equivalent to "update", - * "vwait -nofileevents -notimerevents -nowindowevents" - * is equivalent to "update idletasks" - */ - any = 1; - mask |= TCL_DONT_WAIT; + 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 (!timedOut && foundEvent && - ((!any && (done < numItems)) || (any && !done))) { - foundEvent = Tcl_DoOneEvent(mask); - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - break; - } + while (!done && foundEvent) { + foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); if (Tcl_LimitExceeded(interp)) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", (void *)NULL); break; } - if ((numItems == 0) && (timeout == 0)) { - /* - * Behavior like "update": clear interpreter's result because - * event handlers could have executed commands. - */ - Tcl_ResetResult(interp); - result = TCL_OK; - goto done; - } - } - - if (!foundEvent) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj((numItems == 0) ? - "can't wait: would wait forever" : - "can't wait for variable(s)/channel(s): would wait forever", - -1)); - Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (void *)NULL); - result = TCL_ERROR; - goto done; - } - - if (!done && !timedOut) { - /* - * The interpreter's result was already set to the right error message - * prior to exiting the loop above. - */ - result = TCL_ERROR; - goto done; - } - - result = TCL_OK; - if (timeout <= 0) { - /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. - */ - Tcl_ResetResult(interp); - goto done; } + Tcl_UntraceVar(interp, nameString, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); /* - * When timeout was specified, report milliseconds left or -1 on timeout. + * Clear out the interpreter's result, since it may have been set by event + * handlers. */ - if (timedOut) { - diff = -1; - } else { - Tcl_GetTime(&after); - diff = after.sec * 1000 + after.usec / 1000; - diff -= before.sec * 1000 + before.usec / 1000; - diff = timeout - diff; - if (diff < 0) { - diff = 0; - } - } - - done: - if ((timeout > 0) && (timer != NULL)) { - Tcl_DeleteTimerHandler(timer); - } - if (result != TCL_OK) { - saved = Tcl_SaveInterpState(interp, result); - } - for (i = 0; i < numItems; i++) { - if (vwaitItems[i].mask & TCL_READABLE) { - if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj, - &chan, &mode, 0) == TCL_OK) { - Tcl_DeleteChannelHandler(chan, VwaitChannelReadProc, - &vwaitItems[i]); - } - } else if (vwaitItems[i].mask & TCL_WRITABLE) { - if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj, - &chan, &mode, 0) == TCL_OK) { - Tcl_DeleteChannelHandler(chan, VwaitChannelWriteProc, - &vwaitItems[i]); - } - } else { - Tcl_UntraceVar2(interp, TclGetString(vwaitItems[i].sourceObj), - NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, &vwaitItems[i]); - } - } - - if (result == TCL_OK) { - if (extended) { - int k; - Tcl_Obj *listObj, *keyObj; - - TclNewObj(listObj); - for (k = 0; k < done; k++) { - for (i = 0; i < numItems; i++) { - if (vwaitItems[i].sequence != k) { - continue; - } - if (vwaitItems[i].mask & TCL_READABLE) { - TclNewLiteralStringObj(keyObj, "readable"); - } else if (vwaitItems[i].mask & TCL_WRITABLE) { - TclNewLiteralStringObj(keyObj, "writable"); - } else { - TclNewLiteralStringObj(keyObj, "variable"); - } - Tcl_ListObjAppendElement(NULL, listObj, keyObj); - Tcl_ListObjAppendElement(NULL, listObj, - vwaitItems[i].sourceObj); - } - } - if (timeout > 0) { - TclNewLiteralStringObj(keyObj, "timeleft"); - Tcl_ListObjAppendElement(NULL, listObj, keyObj); - Tcl_ListObjAppendElement(NULL, listObj, - Tcl_NewWideIntObj(diff)); - } - Tcl_SetObjResult(interp, listObj); - } else if (timeout > 0) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(diff)); - } - } else { - result = Tcl_RestoreInterpState(interp, saved); - } - if (vwaitItems != localItems) { - ckfree(vwaitItems); - } - return result; -} - -static void -VwaitChannelReadProc( - void *clientData, /* Pointer to vwait info record. */ - int mask) /* Event mask, must be TCL_READABLE. */ -{ - VwaitItem *itemPtr = (VwaitItem *) clientData; - - if (!(mask & TCL_READABLE)) { - return; - } - if (itemPtr->donePtr != NULL) { - itemPtr->sequence = itemPtr->donePtr[0]; - itemPtr->donePtr[0] += 1; - itemPtr->donePtr = NULL; - } -} -static void -VwaitChannelWriteProc( - void *clientData, /* Pointer to vwait info record. */ - int mask) /* Event mask, must be TCL_WRITABLE. */ -{ - VwaitItem *itemPtr = (VwaitItem *) clientData; - - if (!(mask & TCL_WRITABLE)) { - return; - } - if (itemPtr->donePtr != NULL) { - itemPtr->sequence = itemPtr->donePtr[0]; - itemPtr->donePtr[0] += 1; - itemPtr->donePtr = NULL; + Tcl_ResetResult(interp); + if (!foundEvent) { + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, + "\": would wait forever", NULL); + return TCL_ERROR; } -} - -static void -VwaitTimeoutProc( - void *clientData) /* Pointer to vwait info record. */ -{ - VwaitItem *itemPtr = (VwaitItem *) clientData; - - if (itemPtr->donePtr != NULL) { - itemPtr->donePtr[0] = 1; - itemPtr->donePtr = NULL; + if (!done) { + Tcl_AppendResult(interp, "limit exceeded", NULL); + return TCL_ERROR; } + return TCL_OK; } + /* ARGSUSED */ static char * VwaitVarProc( - void *clientData, /* Pointer to vwait info record. */ + 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. */ - TCL_UNUSED(int) /*flags*/) /* Information about what happened. */ + CONST char *name1, /* Name of variable. */ + CONST char *name2, /* Second part of variable name. */ + int flags) /* Information about what happened. */ { - VwaitItem *itemPtr = (VwaitItem *) clientData; + int *donePtr = (int *) clientData; - if (itemPtr->donePtr != NULL) { - itemPtr->sequence = itemPtr->donePtr[0]; - itemPtr->donePtr[0] += 1; - itemPtr->donePtr = NULL; - } - Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, clientData); + *donePtr = 1; return NULL; } @@ -1957,17 +1399,18 @@ VwaitVarProc( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_UpdateObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - int flags = 0; /* Initialized to avoid compiler warning. */ - static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptionsEnum {OPT_IDLETASKS}; 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; @@ -1976,9 +1419,9 @@ Tcl_UpdateObjCmd( "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum updateOptionsEnum) optionIndex) { - case OPT_IDLETASKS: - flags = 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: Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); @@ -1989,12 +1432,9 @@ Tcl_UpdateObjCmd( } while (Tcl_DoOneEvent(flags) != 0) { - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - return TCL_ERROR; - } if (Tcl_LimitExceeded(interp)) { Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1)); + Tcl_AppendResult(interp, "limit exceeded", NULL); return TCL_ERROR; } } @@ -2008,13 +1448,13 @@ Tcl_UpdateObjCmd( return TCL_OK; } -#if TCL_THREADS +#ifdef TCL_THREADS /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- * * NewThreadProc -- * - * Bootstrap function of a new Tcl thread. + * Bootstrap function of a new Tcl thread. * * Results: * None. @@ -2022,22 +1462,23 @@ Tcl_UpdateObjCmd( * Side Effects: * Initializes Tcl notifier for the current thread. * - *---------------------------------------------------------------------- + *----------------------------------------------------------------------------- */ static Tcl_ThreadCreateType NewThreadProc( - void *clientData) + ClientData clientData) { - ThreadClientData *cdPtr = (ThreadClientData *)clientData; - void *threadClientData; + ThreadClientData *cdPtr; + ClientData threadClientData; Tcl_ThreadCreateProc *threadProc; + cdPtr = (ThreadClientData *) clientData; threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; - ckfree(clientData); /* Allocated in Tcl_CreateThread() */ + ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */ - threadProc(threadClientData); + (*threadProc)(threadClientData); TCL_THREAD_CREATE_RETURN; } @@ -2065,30 +1506,22 @@ NewThreadProc( int Tcl_CreateThread( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ - Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ - void *clientData, /* The one argument to Main() */ - TCL_HASH_TYPE stackSize, /* Size of stack for the new 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. */ { -#if TCL_THREADS - ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData)); - int result; +#ifdef TCL_THREADS + ThreadClientData *cdPtr; + cdPtr = (ThreadClientData *) ckalloc(sizeof(ThreadClientData)); cdPtr->proc = proc; cdPtr->clientData = clientData; - result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags); - if (result != TCL_OK) { - ckfree(cdPtr); - } - return result; -#else - (void)idPtr; - (void)proc; - (void)clientData; - (void)stackSize; - (void)flags; + return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr, + stackSize, flags); +#else return TCL_ERROR; #endif /* TCL_THREADS */ } |