diff options
Diffstat (limited to 'tcl8.6/generic/tclTimer.c')
| -rw-r--r-- | tcl8.6/generic/tclTimer.c | 1293 |
1 files changed, 0 insertions, 1293 deletions
diff --git a/tcl8.6/generic/tclTimer.c b/tcl8.6/generic/tclTimer.c deleted file mode 100644 index c10986a..0000000 --- a/tcl8.6/generic/tclTimer.c +++ /dev/null @@ -1,1293 +0,0 @@ -/* - * tclTimer.c -- - * - * This file provides timer event management facilities for Tcl, - * including the "after" command. - * - * Copyright (c) 1997 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" - -/* - * For each timer callback that's pending there is one record of the following - * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained - * together in a list sorted by time (earliest event first). - */ - -typedef struct TimerHandler { - Tcl_Time time; /* When timer is to fire. */ - Tcl_TimerProc *proc; /* Function to call. */ - ClientData clientData; /* Argument to pass to proc. */ - Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ - struct TimerHandler *nextPtr; - /* Next event in queue, or NULL for end of - * queue. */ -} TimerHandler; - -/* - * The data structure below is used by the "after" command to remember the - * command to be executed later. All of the pending "after" commands for an - * interpreter are linked together in a list. - */ - -typedef struct AfterInfo { - struct AfterAssocData *assocPtr; - /* Pointer to the "tclAfter" assocData for the - * interp in which command will be - * executed. */ - Tcl_Obj *commandPtr; /* Command to execute. */ - int id; /* Integer identifier for command; used to - * cancel it. */ - Tcl_TimerToken token; /* Used to cancel the "after" command. NULL - * means that the command is run as an idle - * handler rather than as a timer handler. - * NULL means this is an "after idle" handler - * rather than a timer handler. */ - struct AfterInfo *nextPtr; /* Next in list of all "after" commands for - * this interpreter. */ -} AfterInfo; - -/* - * One of the following structures is associated with each interpreter for - * which an "after" command has ever been invoked. A pointer to this structure - * is stored in the AssocData for the "tclAfter" key. - */ - -typedef struct AfterAssocData { - Tcl_Interp *interp; /* The interpreter for which this data is - * registered. */ - AfterInfo *firstAfterPtr; /* First in list of all "after" commands still - * pending for this interpreter, or NULL if - * none. */ -} AfterAssocData; - -/* - * There is one of the following structures for each of the handlers declared - * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are - * linked together into a list. - */ - -typedef struct IdleHandler { - Tcl_IdleProc *proc; /* Function to call. */ - ClientData clientData; /* Value to pass to proc. */ - int generation; /* Used to distinguish older handlers from - * recently-created ones. */ - struct IdleHandler *nextPtr;/* Next in list of active handlers. */ -} IdleHandler; - -/* - * The timer and idle queues are per-thread because they are associated with - * the notifier, which is also per-thread. - * - * All static variables used in this file are collected into a single instance - * of the following structure. For multi-threaded implementations, there is - * one instance of this structure for each thread. - * - * Notice that different structures with the same name appear in other files. - * The structure defined below is used in this file only. - */ - -typedef struct ThreadSpecificData { - TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ - int lastTimerId; /* Timer identifier of most recently created - * timer. */ - int timerPending; /* 1 if a timer event is in the queue. */ - IdleHandler *idleList; /* First in list of all idle handlers. */ - IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */ - int idleGeneration; /* Used to fill in the "generation" fields of - * IdleHandler structures. Increments each - * time Tcl_DoOneEvent starts calling idle - * handlers, so that all old handlers can be - * called without calling any of the new ones - * created by old ones. */ - int afterId; /* For unique identifiers of after events. */ -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * Helper macros for working with times. TCL_TIME_BEFORE encodes how to write - * the ordering relation on (normalized) times, and TCL_TIME_DIFF_MS computes - * the number of milliseconds difference between two times. Both macros use - * both of their arguments multiple times, so make sure they are cheap and - * side-effect free. The "prototypes" for these macros are: - * - * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2); - * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); - */ - -#define TCL_TIME_BEFORE(t1, t2) \ - (((t1).sec<(t2).sec) || ((t1).sec==(t2).sec && (t1).usec<(t2).usec)) - -#define TCL_TIME_DIFF_MS(t1, t2) \ - (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ - ((long)(t1).usec - (long)(t2).usec)/1000) - -#define TCL_TIME_DIFF_MS_CEILING(t1, t2) \ - (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ - ((long)(t1).usec - (long)(t2).usec + 999)/1000) - -/* - * Sleeps under that number of milliseconds don't get double-checked - * and are done in exactly one Tcl_Sleep(). This to limit gettimeofday()s. - */ - -#define SLEEP_OFFLOAD_GETTIMEOFDAY 20 - -/* - * The maximum number of milliseconds for each Tcl_Sleep call in AfterDelay. - * This is used to limit the maximum lag between interp limit and script - * cancellation checks. - */ - -#define TCL_TIME_MAXIMUM_SLICE 500 - -/* - * Prototypes for functions referenced only in this file: - */ - -static void AfterCleanupProc(ClientData clientData, - Tcl_Interp *interp); -static int AfterDelay(Tcl_Interp *interp, Tcl_WideInt ms); -static void AfterProc(ClientData clientData); -static void FreeAfterPtr(AfterInfo *afterPtr); -static AfterInfo * GetAfterEvent(AfterAssocData *assocPtr, - Tcl_Obj *commandPtr); -static ThreadSpecificData *InitTimer(void); -static void TimerExitProc(ClientData clientData); -static int TimerHandlerEventProc(Tcl_Event *evPtr, int flags); -static void TimerCheckProc(ClientData clientData, int flags); -static void TimerSetupProc(ClientData clientData, int flags); - -/* - *---------------------------------------------------------------------- - * - * InitTimer -- - * - * This function initializes the timer module. - * - * Results: - * A pointer to the thread specific data. - * - * Side effects: - * Registers the idle and timer event sources. - * - *---------------------------------------------------------------------- - */ - -static ThreadSpecificData * -InitTimer(void) -{ - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); - Tcl_CreateThreadExitHandler(TimerExitProc, NULL); - } - return tsdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TimerExitProc -- - * - * This function is call at exit or unload time to remove the timer and - * idle event sources. - * - * Results: - * None. - * - * Side effects: - * Removes the timer and idle event sources and remaining events. - * - *---------------------------------------------------------------------- - */ - -static void -TimerExitProc( - ClientData clientData) /* Not used. */ -{ - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); - if (tsdPtr != NULL) { - register TimerHandler *timerHandlerPtr; - - timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; - while (timerHandlerPtr != NULL) { - tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - ckfree(timerHandlerPtr); - timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; - } - } -} - -/* - *-------------------------------------------------------------- - * - * Tcl_CreateTimerHandler -- - * - * Arrange for a given function to be invoked at a particular time in the - * future. - * - * Results: - * The return value is a token for the timer event, which may be used to - * delete the event before it fires. - * - * Side effects: - * When milliseconds have elapsed, proc will be invoked exactly once. - * - *-------------------------------------------------------------- - */ - -Tcl_TimerToken -Tcl_CreateTimerHandler( - int milliseconds, /* How many milliseconds to wait before - * invoking proc. */ - Tcl_TimerProc *proc, /* Function to invoke. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ -{ - Tcl_Time time; - - /* - * Compute when the event should fire. - */ - - Tcl_GetTime(&time); - time.sec += milliseconds/1000; - time.usec += (milliseconds%1000)*1000; - if (time.usec >= 1000000) { - time.usec -= 1000000; - time.sec += 1; - } - return TclCreateAbsoluteTimerHandler(&time, proc, clientData); -} - -/* - *-------------------------------------------------------------- - * - * TclCreateAbsoluteTimerHandler -- - * - * Arrange for a given function to be invoked at a particular time in the - * future. - * - * Results: - * The return value is a token for the timer event, which may be used to - * delete the event before it fires. - * - * Side effects: - * When the time in timePtr has been reached, proc will be invoked - * exactly once. - * - *-------------------------------------------------------------- - */ - -Tcl_TimerToken -TclCreateAbsoluteTimerHandler( - Tcl_Time *timePtr, - Tcl_TimerProc *proc, - ClientData clientData) -{ - register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; - ThreadSpecificData *tsdPtr = InitTimer(); - - timerHandlerPtr = ckalloc(sizeof(TimerHandler)); - - /* - * Fill in fields for the event. - */ - - memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time)); - timerHandlerPtr->proc = proc; - timerHandlerPtr->clientData = clientData; - tsdPtr->lastTimerId++; - timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId); - - /* - * Add the event to the queue in the correct position - * (ordered by event firing time). - */ - - for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; - prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { - if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) { - break; - } - } - timerHandlerPtr->nextPtr = tPtr2; - if (prevPtr == NULL) { - tsdPtr->firstTimerHandlerPtr = timerHandlerPtr; - } else { - prevPtr->nextPtr = timerHandlerPtr; - } - - TimerSetupProc(NULL, TCL_ALL_EVENTS); - - return timerHandlerPtr->token; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DeleteTimerHandler -- - * - * Delete a previously-registered timer handler. - * - * Results: - * None. - * - * Side effects: - * Destroy the timer callback identified by TimerToken, so that its - * associated function will not be called. If the callback has already - * fired, or if the given token doesn't exist, then nothing happens. - * - *-------------------------------------------------------------- - */ - -void -Tcl_DeleteTimerHandler( - Tcl_TimerToken token) /* Result previously returned by - * Tcl_DeleteTimerHandler. */ -{ - register TimerHandler *timerHandlerPtr, *prevPtr; - ThreadSpecificData *tsdPtr = InitTimer(); - - if (token == NULL) { - return; - } - - for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; - timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, - timerHandlerPtr = timerHandlerPtr->nextPtr) { - if (timerHandlerPtr->token != token) { - continue; - } - if (prevPtr == NULL) { - tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - } else { - prevPtr->nextPtr = timerHandlerPtr->nextPtr; - } - ckfree(timerHandlerPtr); - return; - } -} - -/* - *---------------------------------------------------------------------- - * - * TimerSetupProc -- - * - * This function is called by Tcl_DoOneEvent to setup the timer event - * source for before blocking. This routine checks both the idle and - * after timer lists. - * - * Results: - * None. - * - * Side effects: - * May update the maximum notifier block time. - * - *---------------------------------------------------------------------- - */ - -static void -TimerSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - Tcl_Time blockTime; - ThreadSpecificData *tsdPtr = InitTimer(); - - if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList) - || ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) { - /* - * There is an idle handler or a pending timer event, so just poll. - */ - - blockTime.sec = 0; - blockTime.usec = 0; - } else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) { - /* - * Compute the timeout for the next timer on the list. - */ - - Tcl_GetTime(&blockTime); - blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec; - blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec - - blockTime.usec; - if (blockTime.usec < 0) { - blockTime.sec -= 1; - blockTime.usec += 1000000; - } - if (blockTime.sec < 0) { - blockTime.sec = 0; - blockTime.usec = 0; - } - } else { - return; - } - - Tcl_SetMaxBlockTime(&blockTime); -} - -/* - *---------------------------------------------------------------------- - * - * TimerCheckProc -- - * - * This function is called by Tcl_DoOneEvent to check the timer event - * source for events. This routine checks both the idle and after timer - * lists. - * - * Results: - * None. - * - * Side effects: - * May queue an event and update the maximum notifier block time. - * - *---------------------------------------------------------------------- - */ - -static void -TimerCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - Tcl_Event *timerEvPtr; - Tcl_Time blockTime; - ThreadSpecificData *tsdPtr = InitTimer(); - - if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) { - /* - * Compute the timeout for the next timer on the list. - */ - - Tcl_GetTime(&blockTime); - blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec; - blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec - - blockTime.usec; - if (blockTime.usec < 0) { - blockTime.sec -= 1; - blockTime.usec += 1000000; - } - if (blockTime.sec < 0) { - blockTime.sec = 0; - blockTime.usec = 0; - } - - /* - * If the first timer has expired, stick an event on the queue. - */ - - if (blockTime.sec == 0 && blockTime.usec == 0 && - !tsdPtr->timerPending) { - tsdPtr->timerPending = 1; - timerEvPtr = ckalloc(sizeof(Tcl_Event)); - timerEvPtr->proc = TimerHandlerEventProc; - Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TimerHandlerEventProc -- - * - * This function is called by Tcl_ServiceEvent when a timer event reaches - * the front of the event queue. This function handles the event by - * invoking the callbacks for all timers that are ready. - * - * Results: - * Returns 1 if the event was handled, meaning it should be removed from - * the queue. Returns 0 if the event was not handled, meaning it should - * stay on the queue. The only time the event isn't handled is if the - * TCL_TIMER_EVENTS flag bit isn't set. - * - * Side effects: - * Whatever the timer handler callback functions do. - * - *---------------------------------------------------------------------- - */ - -static int -TimerHandlerEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to handle, - * such as TCL_FILE_EVENTS. */ -{ - TimerHandler *timerHandlerPtr, **nextPtrPtr; - Tcl_Time time; - int currentTimerId; - ThreadSpecificData *tsdPtr = InitTimer(); - - /* - * Do nothing if timers aren't enabled. This leaves the event on the - * queue, so we will get to it as soon as ServiceEvents() is called with - * timers enabled. - */ - - if (!(flags & TCL_TIMER_EVENTS)) { - return 0; - } - - /* - * The code below is trickier than it may look, for the following reasons: - * - * 1. New handlers can get added to the list while the current one is - * being processed. If new ones get added, we don't want to process - * them during this pass through the list to avoid starving other event - * sources. This is implemented using the token number in the handler: - * new handlers will have a newer token than any of the ones currently - * on the list. - * 2. The handler can call Tcl_DoOneEvent, so we have to remove the - * handler from the list before calling it. Otherwise an infinite loop - * could result. - * 3. Tcl_DeleteTimerHandler can be called to remove an element from the - * list while a handler is executing, so the list could change - * structure during the call. - * 4. Because we only fetch the current time before entering the loop, the - * only way a new timer will even be considered runnable is if its - * expiration time is within the same millisecond as the current time. - * This is fairly likely on Windows, since it has a course granularity - * clock. Since timers are placed on the queue in time order with the - * most recently created handler appearing after earlier ones with the - * same expiration time, we don't have to worry about newer generation - * timers appearing before later ones. - */ - - tsdPtr->timerPending = 0; - currentTimerId = tsdPtr->lastTimerId; - Tcl_GetTime(&time); - while (1) { - nextPtrPtr = &tsdPtr->firstTimerHandlerPtr; - timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; - if (timerHandlerPtr == NULL) { - break; - } - - if (TCL_TIME_BEFORE(time, timerHandlerPtr->time)) { - break; - } - - /* - * Bail out if the next timer is of a newer generation. - */ - - if ((currentTimerId - PTR2INT(timerHandlerPtr->token)) < 0) { - break; - } - - /* - * Remove the handler from the queue before invoking it, to avoid - * potential reentrancy problems. - */ - - *nextPtrPtr = timerHandlerPtr->nextPtr; - timerHandlerPtr->proc(timerHandlerPtr->clientData); - ckfree(timerHandlerPtr); - } - TimerSetupProc(NULL, TCL_TIMER_EVENTS); - return 1; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_DoWhenIdle -- - * - * Arrange for proc to be invoked the next time the system is idle (i.e., - * just before the next time that Tcl_DoOneEvent would have to wait for - * something to happen). - * - * Results: - * None. - * - * Side effects: - * Proc will eventually be called, with clientData as argument. See the - * manual entry for details. - * - *-------------------------------------------------------------- - */ - -void -Tcl_DoWhenIdle( - Tcl_IdleProc *proc, /* Function to invoke. */ - ClientData clientData) /* Arbitrary value to pass to proc. */ -{ - register IdleHandler *idlePtr; - Tcl_Time blockTime; - ThreadSpecificData *tsdPtr = InitTimer(); - - idlePtr = ckalloc(sizeof(IdleHandler)); - idlePtr->proc = proc; - idlePtr->clientData = clientData; - idlePtr->generation = tsdPtr->idleGeneration; - idlePtr->nextPtr = NULL; - if (tsdPtr->lastIdlePtr == NULL) { - tsdPtr->idleList = idlePtr; - } else { - tsdPtr->lastIdlePtr->nextPtr = idlePtr; - } - tsdPtr->lastIdlePtr = idlePtr; - - blockTime.sec = 0; - blockTime.usec = 0; - Tcl_SetMaxBlockTime(&blockTime); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CancelIdleCall -- - * - * If there are any when-idle calls requested to a given function with - * given clientData, cancel all of them. - * - * Results: - * None. - * - * Side effects: - * If the proc/clientData combination were on the when-idle list, they - * are removed so that they will never be called. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_CancelIdleCall( - Tcl_IdleProc *proc, /* Function that was previously registered. */ - ClientData clientData) /* Arbitrary value to pass to proc. */ -{ - register IdleHandler *idlePtr, *prevPtr; - IdleHandler *nextPtr; - ThreadSpecificData *tsdPtr = InitTimer(); - - for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL; - prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { - while ((idlePtr->proc == proc) - && (idlePtr->clientData == clientData)) { - nextPtr = idlePtr->nextPtr; - ckfree(idlePtr); - idlePtr = nextPtr; - if (prevPtr == NULL) { - tsdPtr->idleList = idlePtr; - } else { - prevPtr->nextPtr = idlePtr; - } - if (idlePtr == NULL) { - tsdPtr->lastIdlePtr = prevPtr; - return; - } - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclServiceIdle -- - * - * This function is invoked by the notifier when it becomes idle. It will - * invoke all idle handlers that are present at the time the call is - * invoked, but not those added during idle processing. - * - * Results: - * The return value is 1 if TclServiceIdle found something to do, - * otherwise return value is 0. - * - * Side effects: - * Invokes all pending idle handlers. - * - *---------------------------------------------------------------------- - */ - -int -TclServiceIdle(void) -{ - IdleHandler *idlePtr; - int oldGeneration; - Tcl_Time blockTime; - ThreadSpecificData *tsdPtr = InitTimer(); - - if (tsdPtr->idleList == NULL) { - return 0; - } - - oldGeneration = tsdPtr->idleGeneration; - tsdPtr->idleGeneration++; - - /* - * The code below is trickier than it may look, for the following reasons: - * - * 1. New handlers can get added to the list while the current one is - * being processed. If new ones get added, we don't want to process - * them during this pass through the list (want to check for other work - * to do first). This is implemented using the generation number in the - * handler: new handlers will have a different generation than any of - * the ones currently on the list. - * 2. The handler can call Tcl_DoOneEvent, so we have to remove the - * handler from the list before calling it. Otherwise an infinite loop - * could result. - * 3. Tcl_CancelIdleCall can be called to remove an element from the list - * while a handler is executing, so the list could change structure - * during the call. - */ - - for (idlePtr = tsdPtr->idleList; - ((idlePtr != NULL) - && ((oldGeneration - idlePtr->generation) >= 0)); - idlePtr = tsdPtr->idleList) { - tsdPtr->idleList = idlePtr->nextPtr; - if (tsdPtr->idleList == NULL) { - tsdPtr->lastIdlePtr = NULL; - } - idlePtr->proc(idlePtr->clientData); - ckfree(idlePtr); - } - if (tsdPtr->idleList) { - blockTime.sec = 0; - blockTime.usec = 0; - Tcl_SetMaxBlockTime(&blockTime); - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AfterObjCmd -- - * - * This function is invoked to process the "after" 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_AfterObjCmd( - ClientData clientData, /* Unused */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_WideInt ms = 0; /* Number of milliseconds to wait */ - Tcl_Time wakeup; - AfterInfo *afterPtr; - AfterAssocData *assocPtr; - int length; - int index; - static const char *const afterSubCmds[] = { - "cancel", "idle", "info", NULL - }; - enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; - ThreadSpecificData *tsdPtr = InitTimer(); - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - - /* - * Create the "after" information associated for this interpreter, if it - * doesn't already exist. - */ - - assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL); - if (assocPtr == NULL) { - assocPtr = ckalloc(sizeof(AfterAssocData)); - assocPtr->interp = interp; - assocPtr->firstAfterPtr = NULL; - Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); - } - - /* - * First lets see if the command was passed a number as the first argument. - */ - - if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objv[1]->typePtr == &tclWideIntType -#endif - || objv[1]->typePtr == &tclBignumType - || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, - &index) != TCL_OK)) { - index = -1; - if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { - const char *arg = Tcl_GetString(objv[1]); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad argument \"%s\": must be" - " cancel, idle, info, or an integer", arg)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", - arg, NULL); - return TCL_ERROR; - } - } - - /* - * At this point, either index = -1 and ms contains the number of ms - * to wait, or else index is the index of a subcommand. - */ - - switch (index) { - case -1: { - if (ms < 0) { - ms = 0; - } - if (objc == 2) { - return AfterDelay(interp, ms); - } - afterPtr = ckalloc(sizeof(AfterInfo)); - afterPtr->assocPtr = assocPtr; - if (objc == 3) { - afterPtr->commandPtr = objv[2]; - } else { - afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); - } - Tcl_IncrRefCount(afterPtr->commandPtr); - - /* - * The variable below is used to generate unique identifiers for after - * commands. This id can wrap around, which can potentially cause - * problems. However, there are not likely to be problems in practice, - * because after commands can only be requested to about a month in - * the future, and wrap-around is unlikely to occur in less than about - * 1-10 years. Thus it's unlikely that any old ids will still be - * around when wrap-around occurs. - */ - - afterPtr->id = tsdPtr->afterId; - tsdPtr->afterId += 1; - Tcl_GetTime(&wakeup); - wakeup.sec += (long)(ms / 1000); - wakeup.usec += ((long)(ms % 1000)) * 1000; - if (wakeup.usec > 1000000) { - wakeup.sec++; - wakeup.usec -= 1000000; - } - afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup, - AfterProc, afterPtr); - afterPtr->nextPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr; - Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); - return TCL_OK; - } - case AFTER_CANCEL: { - Tcl_Obj *commandPtr; - const char *command, *tempCommand; - int tempLength; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id|command"); - return TCL_ERROR; - } - if (objc == 3) { - commandPtr = objv[2]; - } else { - commandPtr = Tcl_ConcatObj(objc-2, objv+2);; - } - command = Tcl_GetStringFromObj(commandPtr, &length); - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, - &tempLength); - if ((length == tempLength) - && !memcmp(command, tempCommand, (unsigned) length)) { - break; - } - } - if (afterPtr == NULL) { - afterPtr = GetAfterEvent(assocPtr, commandPtr); - } - if (objc != 3) { - Tcl_DecrRefCount(commandPtr); - } - if (afterPtr != NULL) { - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); - } else { - Tcl_CancelIdleCall(AfterProc, afterPtr); - } - FreeAfterPtr(afterPtr); - } - break; - } - case AFTER_IDLE: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?"); - return TCL_ERROR; - } - afterPtr = ckalloc(sizeof(AfterInfo)); - afterPtr->assocPtr = assocPtr; - if (objc == 3) { - afterPtr->commandPtr = objv[2]; - } else { - afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); - } - Tcl_IncrRefCount(afterPtr->commandPtr); - afterPtr->id = tsdPtr->afterId; - tsdPtr->afterId += 1; - afterPtr->token = NULL; - afterPtr->nextPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr; - Tcl_DoWhenIdle(AfterProc, afterPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id)); - break; - case AFTER_INFO: - if (objc == 2) { - Tcl_Obj *resultObj = Tcl_NewObj(); - - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (assocPtr->interp == interp) { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf( - "after#%d", afterPtr->id)); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?id?"); - return TCL_ERROR; - } - afterPtr = GetAfterEvent(assocPtr, objv[2]); - if (afterPtr == NULL) { - const char *eventStr = TclGetString(objv[2]); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "event \"%s\" doesn't exist", eventStr)); - Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL); - return TCL_ERROR; - } else { - Tcl_Obj *resultListPtr = Tcl_NewObj(); - - Tcl_ListObjAppendElement(interp, resultListPtr, - afterPtr->commandPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( - (afterPtr->token == NULL) ? "idle" : "timer", -1)); - Tcl_SetObjResult(interp, resultListPtr); - } - break; - default: - Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * AfterDelay -- - * - * Implements the blocking delay behaviour of [after $time]. Tricky - * because it has to take into account any time limit that has been set. - * - * Results: - * Standard Tcl result code (with error set if an error occurred due to a - * time limit being exceeded or being canceled). - * - * Side effects: - * May adjust the time limit granularity marker. - * - *---------------------------------------------------------------------- - */ - -static int -AfterDelay( - Tcl_Interp *interp, - Tcl_WideInt ms) -{ - Interp *iPtr = (Interp *) interp; - - Tcl_Time endTime, now; - Tcl_WideInt diff; - - Tcl_GetTime(&now); - endTime = now; - endTime.sec += (long)(ms/1000); - endTime.usec += ((int)(ms%1000))*1000; - if (endTime.usec >= 1000000) { - endTime.sec++; - endTime.usec -= 1000000; - } - - do { - if (Tcl_AsyncReady()) { - if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { - return TCL_ERROR; - } - } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - return TCL_ERROR; - } - if (iPtr->limit.timeEvent != NULL - && TCL_TIME_BEFORE(iPtr->limit.time, now)) { - iPtr->limit.granularityTicker = 0; - if (Tcl_LimitCheck(interp) != TCL_OK) { - return TCL_ERROR; - } - } - if (iPtr->limit.timeEvent == NULL - || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { - diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif - if (diff > TCL_TIME_MAXIMUM_SLICE) { - diff = TCL_TIME_MAXIMUM_SLICE; - } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) diff = 1; - if (diff > 0) { - Tcl_Sleep((long) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) break; - } else break; - } else { - diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif - if (diff > TCL_TIME_MAXIMUM_SLICE) { - diff = TCL_TIME_MAXIMUM_SLICE; - } - if (diff > 0) { - Tcl_Sleep((long) diff); - } - if (Tcl_AsyncReady()) { - if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { - return TCL_ERROR; - } - } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - return TCL_ERROR; - } - if (Tcl_LimitCheck(interp) != TCL_OK) { - return TCL_ERROR; - } - } - Tcl_GetTime(&now); - } while (TCL_TIME_BEFORE(now, endTime)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetAfterEvent -- - * - * This function parses an "after" id such as "after#4" and returns a - * pointer to the AfterInfo structure. - * - * Results: - * The return value is either a pointer to an AfterInfo structure, if one - * is found that corresponds to "cmdString" and is for interp, or NULL if - * no corresponding after event can be found. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static AfterInfo * -GetAfterEvent( - AfterAssocData *assocPtr, /* Points to "after"-related information for - * this interpreter. */ - Tcl_Obj *commandPtr) -{ - const char *cmdString; /* Textual identifier for after event, such as - * "after#6". */ - AfterInfo *afterPtr; - int id; - char *end; - - cmdString = TclGetString(commandPtr); - if (strncmp(cmdString, "after#", 6) != 0) { - return NULL; - } - cmdString += 6; - id = strtoul(cmdString, &end, 10); - if ((end == cmdString) || (*end != 0)) { - return NULL; - } - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (afterPtr->id == id) { - return afterPtr; - } - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * AfterProc -- - * - * Timer callback to execute commands registered with the "after" - * command. - * - * Results: - * None. - * - * Side effects: - * Executes whatever command was specified. If the command returns an - * error, then the command "bgerror" is invoked to process the error; if - * bgerror fails then information about the error is output on stderr. - * - *---------------------------------------------------------------------- - */ - -static void -AfterProc( - ClientData clientData) /* Describes command to execute. */ -{ - AfterInfo *afterPtr = clientData; - AfterAssocData *assocPtr = afterPtr->assocPtr; - AfterInfo *prevPtr; - int result; - Tcl_Interp *interp; - - /* - * First remove the callback from our list of callbacks; otherwise someone - * could delete the callback while it's being executed, which could cause - * a core dump. - */ - - if (assocPtr->firstAfterPtr == afterPtr) { - assocPtr->firstAfterPtr = afterPtr->nextPtr; - } else { - for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; - prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = afterPtr->nextPtr; - } - - /* - * Execute the callback. - */ - - interp = assocPtr->interp; - Tcl_Preserve(interp); - result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); - Tcl_BackgroundException(interp, result); - } - Tcl_Release(interp); - - /* - * Free the memory for the callback. - */ - - Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree(afterPtr); -} - -/* - *---------------------------------------------------------------------- - * - * FreeAfterPtr -- - * - * This function removes an "after" command from the list of those that - * are pending and frees its resources. This function does *not* cancel - * the timer handler; if that's needed, the caller must do it. - * - * Results: - * None. - * - * Side effects: - * The memory associated with afterPtr is released. - * - *---------------------------------------------------------------------- - */ - -static void -FreeAfterPtr( - AfterInfo *afterPtr) /* Command to be deleted. */ -{ - AfterInfo *prevPtr; - AfterAssocData *assocPtr = afterPtr->assocPtr; - - if (assocPtr->firstAfterPtr == afterPtr) { - assocPtr->firstAfterPtr = afterPtr->nextPtr; - } else { - for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; - prevPtr = prevPtr->nextPtr) { - /* Empty loop body. */ - } - prevPtr->nextPtr = afterPtr->nextPtr; - } - Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree(afterPtr); -} - -/* - *---------------------------------------------------------------------- - * - * AfterCleanupProc -- - * - * This function is invoked whenever an interpreter is deleted - * to cleanup the AssocData for "tclAfter". - * - * Results: - * None. - * - * Side effects: - * After commands are removed. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -AfterCleanupProc( - ClientData clientData, /* Points to AfterAssocData for the - * interpreter. */ - Tcl_Interp *interp) /* Interpreter that is being deleted. */ -{ - AfterAssocData *assocPtr = clientData; - AfterInfo *afterPtr; - - while (assocPtr->firstAfterPtr != NULL) { - afterPtr = assocPtr->firstAfterPtr; - assocPtr->firstAfterPtr = afterPtr->nextPtr; - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); - } else { - Tcl_CancelIdleCall(AfterProc, afterPtr); - } - Tcl_DecrRefCount(afterPtr->commandPtr); - ckfree(afterPtr); - } - ckfree(assocPtr); -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil - * End: - */ |