diff options
Diffstat (limited to 'generic/tclTimer.c')
| -rw-r--r-- | generic/tclTimer.c | 1108 |
1 files changed, 1108 insertions, 0 deletions
diff --git a/generic/tclTimer.c b/generic/tclTimer.c new file mode 100644 index 0000000..7bb8e7d --- /dev/null +++ b/generic/tclTimer.c @@ -0,0 +1,1108 @@ +/* + * 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. + * + * SCCS: @(#) tclTimer.c 1.9 97/07/29 16:21:53 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * This flag indicates whether this module has been initialized. + */ + +static int initialized = 0; + +/* + * 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; /* Procedure 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; + +static TimerHandler *firstTimerHandlerPtr = NULL; + /* First event in queue. */ +static int lastTimerId; /* Timer identifier of most recently + * created timer. */ +static int timerPending; /* 1 if a timer event is in the queue. */ + +/* + * 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. */ + char *command; /* Command to execute. Malloc'ed, so must + * be freed when structure is deallocated. */ + 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); /* Procedure 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; + +static IdleHandler *idleList; + /* First in list of all idle handlers. */ +static IdleHandler *lastIdlePtr; + /* Last in list (or NULL for empty list). */ +static 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. */ + +/* + * Prototypes for procedures referenced only in this file: + */ + +static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void AfterProc _ANSI_ARGS_((ClientData clientData)); +static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); +static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, + char *string)); +static void InitTimer _ANSI_ARGS_((void)); +static void TimerExitProc _ANSI_ARGS_((ClientData clientData)); +static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void TimerCheckProc _ANSI_ARGS_((ClientData clientData, + int flags)); +static void TimerSetupProc _ANSI_ARGS_((ClientData clientData, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * InitTimer -- + * + * This function initializes the timer module. + * + * Results: + * None. + * + * Side effects: + * Registers the idle and timer event sources. + * + *---------------------------------------------------------------------- + */ + +static void +InitTimer() +{ + initialized = 1; + lastTimerId = 0; + timerPending = 0; + idleGeneration = 0; + firstTimerHandlerPtr = NULL; + lastIdlePtr = NULL; + idleList = NULL; + + Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); + Tcl_CreateExitHandler(TimerExitProc, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +TimerExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); + initialized = 0; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateTimerHandler -- + * + * Arrange for a given procedure 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(milliseconds, proc, clientData) + int milliseconds; /* How many milliseconds to wait + * before invoking proc. */ + Tcl_TimerProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + Tcl_Time time; + + if (!initialized) { + InitTimer(); + } + + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + + /* + * Compute when the event should fire. + */ + + TclpGetTime(&time); + timerHandlerPtr->time.sec = time.sec + milliseconds/1000; + timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000; + if (timerHandlerPtr->time.usec >= 1000000) { + timerHandlerPtr->time.usec -= 1000000; + timerHandlerPtr->time.sec += 1; + } + + /* + * Fill in other fields for the event. + */ + + timerHandlerPtr->proc = proc; + timerHandlerPtr->clientData = clientData; + lastTimerId++; + timerHandlerPtr->token = (Tcl_TimerToken) lastTimerId; + + /* + * Add the event to the queue in the correct position + * (ordered by event firing time). + */ + + for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; + prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { + if ((tPtr2->time.sec > timerHandlerPtr->time.sec) + || ((tPtr2->time.sec == timerHandlerPtr->time.sec) + && (tPtr2->time.usec > timerHandlerPtr->time.usec))) { + break; + } + } + timerHandlerPtr->nextPtr = tPtr2; + if (prevPtr == NULL) { + 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 procedure will not be called. + * If the callback has already fired, or if the given + * token doesn't exist, then nothing happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteTimerHandler(token) + Tcl_TimerToken token; /* Result previously returned by + * Tcl_DeleteTimerHandler. */ +{ + register TimerHandler *timerHandlerPtr, *prevPtr; + + for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL; + timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, + timerHandlerPtr = timerHandlerPtr->nextPtr) { + if (timerHandlerPtr->token != token) { + continue; + } + if (prevPtr == NULL) { + firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + } else { + prevPtr->nextPtr = timerHandlerPtr->nextPtr; + } + ckfree((char *) 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(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + Tcl_Time blockTime; + + if (((flags & TCL_IDLE_EVENTS) && idleList) + || ((flags & TCL_TIMER_EVENTS) && 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) && firstTimerHandlerPtr) { + /* + * Compute the timeout for the next timer on the list. + */ + + TclpGetTime(&blockTime); + blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = 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(data, flags) + ClientData data; /* Not used. */ + int flags; /* Event flags as passed to Tcl_DoOneEvent. */ +{ + Tcl_Event *timerEvPtr; + Tcl_Time blockTime; + + if ((flags & TCL_TIMER_EVENTS) && firstTimerHandlerPtr) { + /* + * Compute the timeout for the next timer on the list. + */ + + TclpGetTime(&blockTime); + blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = 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 && !timerPending) { + timerPending = 1; + timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event)); + timerEvPtr->proc = TimerHandlerEventProc; + Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerEventProc -- + * + * This procedure is called by Tcl_ServiceEvent when a timer event + * reaches the front of the event queue. This procedure 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 procedures do. + * + *---------------------------------------------------------------------- + */ + +static int +TimerHandlerEventProc(evPtr, flags) + 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; + + /* + * 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. + */ + + timerPending = 0; + currentTimerId = lastTimerId; + TclpGetTime(&time); + while (1) { + nextPtrPtr = &firstTimerHandlerPtr; + timerHandlerPtr = firstTimerHandlerPtr; + if (timerHandlerPtr == NULL) { + break; + } + + if ((timerHandlerPtr->time.sec > time.sec) + || ((timerHandlerPtr->time.sec == time.sec) + && (timerHandlerPtr->time.usec > time.usec))) { + break; + } + + /* + * Bail out if the next timer is of a newer generation. + */ + + if ((currentTimerId - (int)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((char *) 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(proc, clientData) + Tcl_IdleProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr; + Tcl_Time blockTime; + + if (!initialized) { + InitTimer(); + } + + idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); + idlePtr->proc = proc; + idlePtr->clientData = clientData; + idlePtr->generation = idleGeneration; + idlePtr->nextPtr = NULL; + if (lastIdlePtr == NULL) { + idleList = idlePtr; + } else { + lastIdlePtr->nextPtr = idlePtr; + } + lastIdlePtr = idlePtr; + + blockTime.sec = 0; + blockTime.usec = 0; + Tcl_SetMaxBlockTime(&blockTime); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CancelIdleCall -- + * + * If there are any when-idle calls requested to a given procedure + * 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(proc, clientData) + Tcl_IdleProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr, *prevPtr; + IdleHandler *nextPtr; + + for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL; + prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { + while ((idlePtr->proc == proc) + && (idlePtr->clientData == clientData)) { + nextPtr = idlePtr->nextPtr; + ckfree((char *) idlePtr); + idlePtr = nextPtr; + if (prevPtr == NULL) { + idleList = idlePtr; + } else { + prevPtr->nextPtr = idlePtr; + } + if (idlePtr == NULL) { + lastIdlePtr = prevPtr; + return; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclServiceIdle -- + * + * This procedure 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() +{ + IdleHandler *idlePtr; + int oldGeneration; + Tcl_Time blockTime; + + if (idleList == NULL) { + return 0; + } + + oldGeneration = idleGeneration; + 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 = idleList; + ((idlePtr != NULL) + && ((oldGeneration - idlePtr->generation) >= 0)); + idlePtr = idleList) { + idleList = idlePtr->nextPtr; + if (idleList == NULL) { + lastIdlePtr = NULL; + } + (*idlePtr->proc)(idlePtr->clientData); + ckfree((char *) idlePtr); + } + if (idleList) { + blockTime.sec = 0; + blockTime.usec = 0; + Tcl_SetMaxBlockTime(&blockTime); + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AfterObjCmd -- + * + * This procedure 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, interp, objc, objv) + ClientData clientData; /* Points to the "tclAfter" assocData for + * this interpreter, or NULL if the assocData + * hasn't been created yet.*/ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + /* + * 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. + */ + + static int nextId = 1; + int ms; + AfterInfo *afterPtr; + AfterAssocData *assocPtr = (AfterAssocData *) clientData; + Tcl_CmdInfo cmdInfo; + int length; + char *arg; + int index, result; + static char *subCmds[] = { + "cancel", "idle", "info", + (char *) NULL}; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + + /* + * Create the "after" information associated for this interpreter, + * if it doesn't already exist. Associate it with the command too, + * so that it will be passed in as the ClientData argument in the + * future. + */ + + if (assocPtr == NULL) { + assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); + assocPtr->interp = interp; + assocPtr->firstAfterPtr = NULL; + Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, + (ClientData) assocPtr); + cmdInfo.proc = NULL; + cmdInfo.clientData = (ClientData) NULL; + cmdInfo.objProc = Tcl_AfterObjCmd; + cmdInfo.objClientData = (ClientData) assocPtr; + cmdInfo.deleteProc = NULL; + cmdInfo.deleteData = (ClientData) assocPtr; + Tcl_SetCommandInfo(interp, Tcl_GetStringFromObj(objv[0], &length), + &cmdInfo); + } + + /* + * First lets see if the command was passed a number as the first argument. + */ + + arg = Tcl_GetStringFromObj(objv[1], &length); + if (isdigit(UCHAR(arg[0]))) { + if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { + return TCL_ERROR; + } + if (ms < 0) { + ms = 0; + } + if (objc == 2) { + Tcl_Sleep(ms); + return TCL_OK; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + } else { + Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2); + arg = Tcl_GetStringFromObj(objPtr, &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + Tcl_DecrRefCount(objPtr); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, + (ClientData) afterPtr); + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + sprintf(interp->result, "after#%d", afterPtr->id); + return TCL_OK; + } + + /* + * If it's not a number it must be a subcommand. + */ + result = Tcl_GetIndexFromObj(NULL, objv[1], subCmds, "option", + 0, (int *) &index); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": must be cancel, idle, info, or a number", + (char *) NULL); + return TCL_ERROR; + } + + switch (index) { + case 0: /* cancel */ + { + char *arg; + Tcl_Obj *objPtr = NULL; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id|command"); + return TCL_ERROR; + } + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + } else { + objPtr = Tcl_ConcatObj(objc-2, objv+2);; + arg = Tcl_GetStringFromObj(objPtr, &length); + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (strcmp(afterPtr->command, arg) == 0) { + break; + } + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, arg); + } + if (objPtr != NULL) { + Tcl_DecrRefCount(objPtr); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + FreeAfterPtr(afterPtr); + } + break; + } + case 1: /* idle */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); + return TCL_ERROR; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (objc == 3) { + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr->command = (char *) ckalloc((unsigned) length + 1); + strcpy(afterPtr->command, arg); + } else { + Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);; + arg = Tcl_GetStringFromObj(objPtr, &length); + afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); + strcpy(afterPtr->command, arg); + Tcl_DecrRefCount(objPtr); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = NULL; + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + sprintf(interp->result, "after#%d", afterPtr->id); + break; + case 2: /* info */ + if (objc == 2) { + char buffer[30]; + + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (assocPtr->interp == interp) { + sprintf(buffer, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buffer); + } + } + return TCL_OK; + } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?id?"); + return TCL_ERROR; + } + arg = Tcl_GetStringFromObj(objv[2], &length); + afterPtr = GetAfterEvent(assocPtr, arg); + if (afterPtr == NULL) { + Tcl_AppendResult(interp, "event \"", arg, + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, afterPtr->command); + Tcl_AppendElement(interp, + (afterPtr->token == NULL) ? "idle" : "timer"); + break; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetAfterEvent -- + * + * This procedure 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 "string" and is for interp, + * or NULL if no corresponding after event can be found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static AfterInfo * +GetAfterEvent(assocPtr, string) + AfterAssocData *assocPtr; /* Points to "after"-related information for + * this interpreter. */ + char *string; /* Textual identifier for after event, such + * as "after#6". */ +{ + AfterInfo *afterPtr; + int id; + char *end; + + if (strncmp(string, "after#", 6) != 0) { + return NULL; + } + string += 6; + id = strtoul(string, &end, 10); + if ((end == string) || (*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 clientData; /* Describes command to execute. */ +{ + AfterInfo *afterPtr = (AfterInfo *) 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((ClientData) interp); + result = Tcl_GlobalEval(interp, afterPtr->command); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); + + /* + * Free the memory for the callback. + */ + + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * FreeAfterPtr -- + * + * This procedure removes an "after" command from the list of + * those that are pending and frees its resources. This procedure + * 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(afterPtr) + 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; + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AfterCleanupProc -- + * + * This procedure 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, interp) + ClientData clientData; /* Points to AfterAssocData for the + * interpreter. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + AfterAssocData *assocPtr = (AfterAssocData *) 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, (ClientData) afterPtr); + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); + } + ckfree((char *) assocPtr); +} |