summaryrefslogtreecommitdiffstats
path: root/generic/tclTimer.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTimer.c')
-rw-r--r--generic/tclTimer.c1108
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);
+}