--- /dev/null
+/*
+ * 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);
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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) {
+ TimerHandler *timerHandlerPtr;
+
+ timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
+ while (timerHandlerPtr != NULL) {
+ tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
+ ckfree(timerHandlerPtr);
+ timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
+ }
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * 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)
+{
+ 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;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * 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. */
+{
+ 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;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ }
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * 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. */
+{
+ 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ 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;
+ }
+ }
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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, 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
+ * End:
+ */
OSDN Git Service
