/[dtapublic]/sf_code/esrgpcpj/shared/tcl_base/tcltimer.c
ViewVC logotype

Annotation of /sf_code/esrgpcpj/shared/tcl_base/tcltimer.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 34525 byte(s)
Initial commit.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tcltimer.c,v 1.1.1.1 2001/06/13 04:46:38 dtashley Exp $ */
2    
3     /*
4     * tclTimer.c --
5     *
6     * This file provides timer event management facilities for Tcl,
7     * including the "after" command.
8     *
9     * Copyright (c) 1997 by Sun Microsystems, Inc.
10     *
11     * See the file "license.terms" for information on usage and redistribution
12     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13     *
14     * RCS: @(#) $Id: tcltimer.c,v 1.1.1.1 2001/06/13 04:46:38 dtashley Exp $
15     */
16    
17     #include "tclInt.h"
18     #include "tclPort.h"
19    
20     /*
21     * For each timer callback that's pending there is one record of the following
22     * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
23     * together in a list sorted by time (earliest event first).
24     */
25    
26     typedef struct TimerHandler {
27     Tcl_Time time; /* When timer is to fire. */
28     Tcl_TimerProc *proc; /* Procedure to call. */
29     ClientData clientData; /* Argument to pass to proc. */
30     Tcl_TimerToken token; /* Identifies handler so it can be
31     * deleted. */
32     struct TimerHandler *nextPtr; /* Next event in queue, or NULL for
33     * end of queue. */
34     } TimerHandler;
35    
36     /*
37     * The data structure below is used by the "after" command to remember
38     * the command to be executed later. All of the pending "after" commands
39     * for an interpreter are linked together in a list.
40     */
41    
42     typedef struct AfterInfo {
43     struct AfterAssocData *assocPtr;
44     /* Pointer to the "tclAfter" assocData for
45     * the interp in which command will be
46     * executed. */
47     Tcl_Obj *commandPtr; /* Command to execute. */
48     int id; /* Integer identifier for command; used to
49     * cancel it. */
50     Tcl_TimerToken token; /* Used to cancel the "after" command. NULL
51     * means that the command is run as an
52     * idle handler rather than as a timer
53     * handler. NULL means this is an "after
54     * idle" handler rather than a
55     * timer handler. */
56     struct AfterInfo *nextPtr; /* Next in list of all "after" commands for
57     * this interpreter. */
58     } AfterInfo;
59    
60     /*
61     * One of the following structures is associated with each interpreter
62     * for which an "after" command has ever been invoked. A pointer to
63     * this structure is stored in the AssocData for the "tclAfter" key.
64     */
65    
66     typedef struct AfterAssocData {
67     Tcl_Interp *interp; /* The interpreter for which this data is
68     * registered. */
69     AfterInfo *firstAfterPtr; /* First in list of all "after" commands
70     * still pending for this interpreter, or
71     * NULL if none. */
72     } AfterAssocData;
73    
74     /*
75     * There is one of the following structures for each of the
76     * handlers declared in a call to Tcl_DoWhenIdle. All of the
77     * currently-active handlers are linked together into a list.
78     */
79    
80     typedef struct IdleHandler {
81     Tcl_IdleProc (*proc); /* Procedure to call. */
82     ClientData clientData; /* Value to pass to proc. */
83     int generation; /* Used to distinguish older handlers from
84     * recently-created ones. */
85     struct IdleHandler *nextPtr;/* Next in list of active handlers. */
86     } IdleHandler;
87    
88     /*
89     * The timer and idle queues are per-thread because they are associated
90     * with the notifier, which is also per-thread.
91     *
92     * All static variables used in this file are collected into a single
93     * instance of the following structure. For multi-threaded implementations,
94     * there is one instance of this structure for each thread.
95     *
96     * Notice that different structures with the same name appear in other
97     * files. The structure defined below is used in this file only.
98     */
99    
100     typedef struct ThreadSpecificData {
101     TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
102     int lastTimerId; /* Timer identifier of most recently
103     * created timer. */
104     int timerPending; /* 1 if a timer event is in the queue. */
105     IdleHandler *idleList; /* First in list of all idle handlers. */
106     IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */
107     int idleGeneration; /* Used to fill in the "generation" fields
108     * of IdleHandler structures. Increments
109     * each time Tcl_DoOneEvent starts calling
110     * idle handlers, so that all old handlers
111     * can be called without calling any of the
112     * new ones created by old ones. */
113     int afterId; /* For unique identifiers of after events. */
114     } ThreadSpecificData;
115    
116     static Tcl_ThreadDataKey dataKey;
117    
118     /*
119     * Prototypes for procedures referenced only in this file:
120     */
121    
122     static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
123     Tcl_Interp *interp));
124     static void AfterProc _ANSI_ARGS_((ClientData clientData));
125     static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
126     static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
127     Tcl_Obj *commandPtr));
128     static ThreadSpecificData *InitTimer _ANSI_ARGS_((void));
129     static void TimerExitProc _ANSI_ARGS_((ClientData clientData));
130     static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
131     int flags));
132     static void TimerCheckProc _ANSI_ARGS_((ClientData clientData,
133     int flags));
134     static void TimerSetupProc _ANSI_ARGS_((ClientData clientData,
135     int flags));
136    
137     /*
138     *----------------------------------------------------------------------
139     *
140     * InitTimer --
141     *
142     * This function initializes the timer module.
143     *
144     * Results:
145     * A pointer to the thread specific data.
146     *
147     * Side effects:
148     * Registers the idle and timer event sources.
149     *
150     *----------------------------------------------------------------------
151     */
152    
153     static ThreadSpecificData *
154     InitTimer()
155     {
156     ThreadSpecificData *tsdPtr =
157     (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
158    
159     if (tsdPtr == NULL) {
160     tsdPtr = TCL_TSD_INIT(&dataKey);
161     Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
162     Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
163     }
164     return tsdPtr;
165     }
166    
167     /*
168     *----------------------------------------------------------------------
169     *
170     * TimerExitProc --
171     *
172     * This function is call at exit or unload time to remove the
173     * timer and idle event sources.
174     *
175     * Results:
176     * None.
177     *
178     * Side effects:
179     * Removes the timer and idle event sources.
180     *
181     *----------------------------------------------------------------------
182     */
183    
184     static void
185     TimerExitProc(clientData)
186     ClientData clientData; /* Not used. */
187     {
188     Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
189     }
190    
191     /*
192     *--------------------------------------------------------------
193     *
194     * Tcl_CreateTimerHandler --
195     *
196     * Arrange for a given procedure to be invoked at a particular
197     * time in the future.
198     *
199     * Results:
200     * The return value is a token for the timer event, which
201     * may be used to delete the event before it fires.
202     *
203     * Side effects:
204     * When milliseconds have elapsed, proc will be invoked
205     * exactly once.
206     *
207     *--------------------------------------------------------------
208     */
209    
210     Tcl_TimerToken
211     Tcl_CreateTimerHandler(milliseconds, proc, clientData)
212     int milliseconds; /* How many milliseconds to wait
213     * before invoking proc. */
214     Tcl_TimerProc *proc; /* Procedure to invoke. */
215     ClientData clientData; /* Arbitrary data to pass to proc. */
216     {
217     register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
218     Tcl_Time time;
219     ThreadSpecificData *tsdPtr;
220    
221     tsdPtr = InitTimer();
222    
223     timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
224    
225     /*
226     * Compute when the event should fire.
227     */
228    
229     TclpGetTime(&time);
230     timerHandlerPtr->time.sec = time.sec + milliseconds/1000;
231     timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000;
232     if (timerHandlerPtr->time.usec >= 1000000) {
233     timerHandlerPtr->time.usec -= 1000000;
234     timerHandlerPtr->time.sec += 1;
235     }
236    
237     /*
238     * Fill in other fields for the event.
239     */
240    
241     timerHandlerPtr->proc = proc;
242     timerHandlerPtr->clientData = clientData;
243     tsdPtr->lastTimerId++;
244     timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId;
245    
246     /*
247     * Add the event to the queue in the correct position
248     * (ordered by event firing time).
249     */
250    
251     for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
252     prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
253     if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
254     || ((tPtr2->time.sec == timerHandlerPtr->time.sec)
255     && (tPtr2->time.usec > timerHandlerPtr->time.usec))) {
256     break;
257     }
258     }
259     timerHandlerPtr->nextPtr = tPtr2;
260     if (prevPtr == NULL) {
261     tsdPtr->firstTimerHandlerPtr = timerHandlerPtr;
262     } else {
263     prevPtr->nextPtr = timerHandlerPtr;
264     }
265    
266     TimerSetupProc(NULL, TCL_ALL_EVENTS);
267    
268     return timerHandlerPtr->token;
269     }
270    
271     /*
272     *--------------------------------------------------------------
273     *
274     * Tcl_DeleteTimerHandler --
275     *
276     * Delete a previously-registered timer handler.
277     *
278     * Results:
279     * None.
280     *
281     * Side effects:
282     * Destroy the timer callback identified by TimerToken,
283     * so that its associated procedure will not be called.
284     * If the callback has already fired, or if the given
285     * token doesn't exist, then nothing happens.
286     *
287     *--------------------------------------------------------------
288     */
289    
290     void
291     Tcl_DeleteTimerHandler(token)
292     Tcl_TimerToken token; /* Result previously returned by
293     * Tcl_DeleteTimerHandler. */
294     {
295     register TimerHandler *timerHandlerPtr, *prevPtr;
296     ThreadSpecificData *tsdPtr;
297    
298     tsdPtr = InitTimer();
299     for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
300     timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
301     timerHandlerPtr = timerHandlerPtr->nextPtr) {
302     if (timerHandlerPtr->token != token) {
303     continue;
304     }
305     if (prevPtr == NULL) {
306     tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
307     } else {
308     prevPtr->nextPtr = timerHandlerPtr->nextPtr;
309     }
310     ckfree((char *) timerHandlerPtr);
311     return;
312     }
313     }
314    
315     /*
316     *----------------------------------------------------------------------
317     *
318     * TimerSetupProc --
319     *
320     * This function is called by Tcl_DoOneEvent to setup the timer
321     * event source for before blocking. This routine checks both the
322     * idle and after timer lists.
323     *
324     * Results:
325     * None.
326     *
327     * Side effects:
328     * May update the maximum notifier block time.
329     *
330     *----------------------------------------------------------------------
331     */
332    
333     static void
334     TimerSetupProc(data, flags)
335     ClientData data; /* Not used. */
336     int flags; /* Event flags as passed to Tcl_DoOneEvent. */
337     {
338     Tcl_Time blockTime;
339     ThreadSpecificData *tsdPtr = InitTimer();
340    
341     if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList)
342     || ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) {
343     /*
344     * There is an idle handler or a pending timer event, so just poll.
345     */
346    
347     blockTime.sec = 0;
348     blockTime.usec = 0;
349    
350     } else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
351     /*
352     * Compute the timeout for the next timer on the list.
353     */
354    
355     TclpGetTime(&blockTime);
356     blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
357     blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
358     blockTime.usec;
359     if (blockTime.usec < 0) {
360     blockTime.sec -= 1;
361     blockTime.usec += 1000000;
362     }
363     if (blockTime.sec < 0) {
364     blockTime.sec = 0;
365     blockTime.usec = 0;
366     }
367     } else {
368     return;
369     }
370    
371     Tcl_SetMaxBlockTime(&blockTime);
372     }
373    
374     /*
375     *----------------------------------------------------------------------
376     *
377     * TimerCheckProc --
378     *
379     * This function is called by Tcl_DoOneEvent to check the timer
380     * event source for events. This routine checks both the
381     * idle and after timer lists.
382     *
383     * Results:
384     * None.
385     *
386     * Side effects:
387     * May queue an event and update the maximum notifier block time.
388     *
389     *----------------------------------------------------------------------
390     */
391    
392     static void
393     TimerCheckProc(data, flags)
394     ClientData data; /* Not used. */
395     int flags; /* Event flags as passed to Tcl_DoOneEvent. */
396     {
397     Tcl_Event *timerEvPtr;
398     Tcl_Time blockTime;
399     ThreadSpecificData *tsdPtr = InitTimer();
400    
401     if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
402     /*
403     * Compute the timeout for the next timer on the list.
404     */
405    
406     TclpGetTime(&blockTime);
407     blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
408     blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
409     blockTime.usec;
410     if (blockTime.usec < 0) {
411     blockTime.sec -= 1;
412     blockTime.usec += 1000000;
413     }
414     if (blockTime.sec < 0) {
415     blockTime.sec = 0;
416     blockTime.usec = 0;
417     }
418    
419     /*
420     * If the first timer has expired, stick an event on the queue.
421     */
422    
423     if (blockTime.sec == 0 && blockTime.usec == 0 &&
424     !tsdPtr->timerPending) {
425     tsdPtr->timerPending = 1;
426     timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event));
427     timerEvPtr->proc = TimerHandlerEventProc;
428     Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
429     }
430     }
431     }
432    
433     /*
434     *----------------------------------------------------------------------
435     *
436     * TimerHandlerEventProc --
437     *
438     * This procedure is called by Tcl_ServiceEvent when a timer event
439     * reaches the front of the event queue. This procedure handles
440     * the event by invoking the callbacks for all timers that are
441     * ready.
442     *
443     * Results:
444     * Returns 1 if the event was handled, meaning it should be removed
445     * from the queue. Returns 0 if the event was not handled, meaning
446     * it should stay on the queue. The only time the event isn't
447     * handled is if the TCL_TIMER_EVENTS flag bit isn't set.
448     *
449     * Side effects:
450     * Whatever the timer handler callback procedures do.
451     *
452     *----------------------------------------------------------------------
453     */
454    
455     static int
456     TimerHandlerEventProc(evPtr, flags)
457     Tcl_Event *evPtr; /* Event to service. */
458     int flags; /* Flags that indicate what events to
459     * handle, such as TCL_FILE_EVENTS. */
460     {
461     TimerHandler *timerHandlerPtr, **nextPtrPtr;
462     Tcl_Time time;
463     int currentTimerId;
464     ThreadSpecificData *tsdPtr = InitTimer();
465    
466     /*
467     * Do nothing if timers aren't enabled. This leaves the event on the
468     * queue, so we will get to it as soon as ServiceEvents() is called
469     * with timers enabled.
470     */
471    
472     if (!(flags & TCL_TIMER_EVENTS)) {
473     return 0;
474     }
475    
476     /*
477     * The code below is trickier than it may look, for the following
478     * reasons:
479     *
480     * 1. New handlers can get added to the list while the current
481     * one is being processed. If new ones get added, we don't
482     * want to process them during this pass through the list to avoid
483     * starving other event sources. This is implemented using the
484     * token number in the handler: new handlers will have a
485     * newer token than any of the ones currently on the list.
486     * 2. The handler can call Tcl_DoOneEvent, so we have to remove
487     * the handler from the list before calling it. Otherwise an
488     * infinite loop could result.
489     * 3. Tcl_DeleteTimerHandler can be called to remove an element from
490     * the list while a handler is executing, so the list could
491     * change structure during the call.
492     * 4. Because we only fetch the current time before entering the loop,
493     * the only way a new timer will even be considered runnable is if
494     * its expiration time is within the same millisecond as the
495     * current time. This is fairly likely on Windows, since it has
496     * a course granularity clock. Since timers are placed
497     * on the queue in time order with the most recently created
498     * handler appearing after earlier ones with the same expiration
499     * time, we don't have to worry about newer generation timers
500     * appearing before later ones.
501     */
502    
503     tsdPtr->timerPending = 0;
504     currentTimerId = tsdPtr->lastTimerId;
505     TclpGetTime(&time);
506     while (1) {
507     nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
508     timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
509     if (timerHandlerPtr == NULL) {
510     break;
511     }
512    
513     if ((timerHandlerPtr->time.sec > time.sec)
514     || ((timerHandlerPtr->time.sec == time.sec)
515     && (timerHandlerPtr->time.usec > time.usec))) {
516     break;
517     }
518    
519     /*
520     * Bail out if the next timer is of a newer generation.
521     */
522    
523     if ((currentTimerId - (int)timerHandlerPtr->token) < 0) {
524     break;
525     }
526    
527     /*
528     * Remove the handler from the queue before invoking it,
529     * to avoid potential reentrancy problems.
530     */
531    
532     (*nextPtrPtr) = timerHandlerPtr->nextPtr;
533     (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
534     ckfree((char *) timerHandlerPtr);
535     }
536     TimerSetupProc(NULL, TCL_TIMER_EVENTS);
537     return 1;
538     }
539    
540     /*
541     *--------------------------------------------------------------
542     *
543     * Tcl_DoWhenIdle --
544     *
545     * Arrange for proc to be invoked the next time the system is
546     * idle (i.e., just before the next time that Tcl_DoOneEvent
547     * would have to wait for something to happen).
548     *
549     * Results:
550     * None.
551     *
552     * Side effects:
553     * Proc will eventually be called, with clientData as argument.
554     * See the manual entry for details.
555     *
556     *--------------------------------------------------------------
557     */
558    
559     void
560     Tcl_DoWhenIdle(proc, clientData)
561     Tcl_IdleProc *proc; /* Procedure to invoke. */
562     ClientData clientData; /* Arbitrary value to pass to proc. */
563     {
564     register IdleHandler *idlePtr;
565     Tcl_Time blockTime;
566     ThreadSpecificData *tsdPtr = InitTimer();
567    
568     idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
569     idlePtr->proc = proc;
570     idlePtr->clientData = clientData;
571     idlePtr->generation = tsdPtr->idleGeneration;
572     idlePtr->nextPtr = NULL;
573     if (tsdPtr->lastIdlePtr == NULL) {
574     tsdPtr->idleList = idlePtr;
575     } else {
576     tsdPtr->lastIdlePtr->nextPtr = idlePtr;
577     }
578     tsdPtr->lastIdlePtr = idlePtr;
579    
580     blockTime.sec = 0;
581     blockTime.usec = 0;
582     Tcl_SetMaxBlockTime(&blockTime);
583     }
584    
585     /*
586     *----------------------------------------------------------------------
587     *
588     * Tcl_CancelIdleCall --
589     *
590     * If there are any when-idle calls requested to a given procedure
591     * with given clientData, cancel all of them.
592     *
593     * Results:
594     * None.
595     *
596     * Side effects:
597     * If the proc/clientData combination were on the when-idle list,
598     * they are removed so that they will never be called.
599     *
600     *----------------------------------------------------------------------
601     */
602    
603     void
604     Tcl_CancelIdleCall(proc, clientData)
605     Tcl_IdleProc *proc; /* Procedure that was previously registered. */
606     ClientData clientData; /* Arbitrary value to pass to proc. */
607     {
608     register IdleHandler *idlePtr, *prevPtr;
609     IdleHandler *nextPtr;
610     ThreadSpecificData *tsdPtr = InitTimer();
611    
612     for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;
613     prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
614     while ((idlePtr->proc == proc)
615     && (idlePtr->clientData == clientData)) {
616     nextPtr = idlePtr->nextPtr;
617     ckfree((char *) idlePtr);
618     idlePtr = nextPtr;
619     if (prevPtr == NULL) {
620     tsdPtr->idleList = idlePtr;
621     } else {
622     prevPtr->nextPtr = idlePtr;
623     }
624     if (idlePtr == NULL) {
625     tsdPtr->lastIdlePtr = prevPtr;
626     return;
627     }
628     }
629     }
630     }
631    
632     /*
633     *----------------------------------------------------------------------
634     *
635     * TclServiceIdle --
636     *
637     * This procedure is invoked by the notifier when it becomes
638     * idle. It will invoke all idle handlers that are present at
639     * the time the call is invoked, but not those added during idle
640     * processing.
641     *
642     * Results:
643     * The return value is 1 if TclServiceIdle found something to
644     * do, otherwise return value is 0.
645     *
646     * Side effects:
647     * Invokes all pending idle handlers.
648     *
649     *----------------------------------------------------------------------
650     */
651    
652     int
653     TclServiceIdle()
654     {
655     IdleHandler *idlePtr;
656     int oldGeneration;
657     Tcl_Time blockTime;
658     ThreadSpecificData *tsdPtr = InitTimer();
659    
660     if (tsdPtr->idleList == NULL) {
661     return 0;
662     }
663    
664     oldGeneration = tsdPtr->idleGeneration;
665     tsdPtr->idleGeneration++;
666    
667     /*
668     * The code below is trickier than it may look, for the following
669     * reasons:
670     *
671     * 1. New handlers can get added to the list while the current
672     * one is being processed. If new ones get added, we don't
673     * want to process them during this pass through the list (want
674     * to check for other work to do first). This is implemented
675     * using the generation number in the handler: new handlers
676     * will have a different generation than any of the ones currently
677     * on the list.
678     * 2. The handler can call Tcl_DoOneEvent, so we have to remove
679     * the handler from the list before calling it. Otherwise an
680     * infinite loop could result.
681     * 3. Tcl_CancelIdleCall can be called to remove an element from
682     * the list while a handler is executing, so the list could
683     * change structure during the call.
684     */
685    
686     for (idlePtr = tsdPtr->idleList;
687     ((idlePtr != NULL)
688     && ((oldGeneration - idlePtr->generation) >= 0));
689     idlePtr = tsdPtr->idleList) {
690     tsdPtr->idleList = idlePtr->nextPtr;
691     if (tsdPtr->idleList == NULL) {
692     tsdPtr->lastIdlePtr = NULL;
693     }
694     (*idlePtr->proc)(idlePtr->clientData);
695     ckfree((char *) idlePtr);
696     }
697     if (tsdPtr->idleList) {
698     blockTime.sec = 0;
699     blockTime.usec = 0;
700     Tcl_SetMaxBlockTime(&blockTime);
701     }
702     return 1;
703     }
704    
705     /*
706     *----------------------------------------------------------------------
707     *
708     * Tcl_AfterObjCmd --
709     *
710     * This procedure is invoked to process the "after" Tcl command.
711     * See the user documentation for details on what it does.
712     *
713     * Results:
714     * A standard Tcl result.
715     *
716     * Side effects:
717     * See the user documentation.
718     *
719     *----------------------------------------------------------------------
720     */
721    
722     /* ARGSUSED */
723     int
724     Tcl_AfterObjCmd(clientData, interp, objc, objv)
725     ClientData clientData; /* Points to the "tclAfter" assocData for
726     * this interpreter, or NULL if the assocData
727     * hasn't been created yet.*/
728     Tcl_Interp *interp; /* Current interpreter. */
729     int objc; /* Number of arguments. */
730     Tcl_Obj *CONST objv[]; /* Argument objects. */
731     {
732     int ms;
733     AfterInfo *afterPtr;
734     AfterAssocData *assocPtr = (AfterAssocData *) clientData;
735     Tcl_CmdInfo cmdInfo;
736     int length;
737     char *argString;
738     int index;
739     char buf[16 + TCL_INTEGER_SPACE];
740     static char *afterSubCmds[] = {"cancel", "idle", "info", (char *) NULL};
741     enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
742     ThreadSpecificData *tsdPtr = InitTimer();
743    
744     if (objc < 2) {
745     Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
746     return TCL_ERROR;
747     }
748    
749     /*
750     * Create the "after" information associated for this interpreter,
751     * if it doesn't already exist. Associate it with the command too,
752     * so that it will be passed in as the ClientData argument in the
753     * future.
754     */
755    
756     if (assocPtr == NULL) {
757     assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
758     assocPtr->interp = interp;
759     assocPtr->firstAfterPtr = NULL;
760     Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
761     (ClientData) assocPtr);
762     cmdInfo.proc = NULL;
763     cmdInfo.clientData = (ClientData) NULL;
764     cmdInfo.objProc = Tcl_AfterObjCmd;
765     cmdInfo.objClientData = (ClientData) assocPtr;
766     cmdInfo.deleteProc = NULL;
767     cmdInfo.deleteData = (ClientData) assocPtr;
768     Tcl_SetCommandInfo(interp, Tcl_GetStringFromObj(objv[0], &length),
769     &cmdInfo);
770     }
771    
772     /*
773     * First lets see if the command was passed a number as the first argument.
774     */
775    
776     if (objv[1]->typePtr == &tclIntType) {
777     ms = (int) objv[1]->internalRep.longValue;
778     goto processInteger;
779     }
780     argString = Tcl_GetStringFromObj(objv[1], &length);
781     if (isdigit(UCHAR(argString[0]))) { /* INTL: digit */
782     if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
783     return TCL_ERROR;
784     }
785     processInteger:
786     if (ms < 0) {
787     ms = 0;
788     }
789     if (objc == 2) {
790     Tcl_Sleep(ms);
791     return TCL_OK;
792     }
793     afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
794     afterPtr->assocPtr = assocPtr;
795     if (objc == 3) {
796     afterPtr->commandPtr = objv[2];
797     } else {
798     afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
799     }
800     Tcl_IncrRefCount(afterPtr->commandPtr);
801     /*
802     * The variable below is used to generate unique identifiers for
803     * after commands. This id can wrap around, which can potentially
804     * cause problems. However, there are not likely to be problems
805     * in practice, because after commands can only be requested to
806     * about a month in the future, and wrap-around is unlikely to
807     * occur in less than about 1-10 years. Thus it's unlikely that
808     * any old ids will still be around when wrap-around occurs.
809     */
810     afterPtr->id = tsdPtr->afterId;
811     tsdPtr->afterId += 1;
812     afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
813     (ClientData) afterPtr);
814     afterPtr->nextPtr = assocPtr->firstAfterPtr;
815     assocPtr->firstAfterPtr = afterPtr;
816     sprintf(buf, "after#%d", afterPtr->id);
817     Tcl_AppendResult(interp, buf, (char *) NULL);
818     return TCL_OK;
819     }
820    
821     /*
822     * If it's not a number it must be a subcommand.
823     */
824    
825     if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument",
826     0, &index) != TCL_OK) {
827     Tcl_AppendResult(interp, "bad argument \"", argString,
828     "\": must be cancel, idle, info, or a number",
829     (char *) NULL);
830     return TCL_ERROR;
831     }
832     switch ((enum afterSubCmds) index) {
833     case AFTER_CANCEL: {
834     Tcl_Obj *commandPtr;
835     char *command, *tempCommand;
836     int tempLength;
837    
838     if (objc < 3) {
839     Tcl_WrongNumArgs(interp, 2, objv, "id|command");
840     return TCL_ERROR;
841     }
842     if (objc == 3) {
843     commandPtr = objv[2];
844     } else {
845     commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
846     }
847     command = Tcl_GetStringFromObj(commandPtr, &length);
848     for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
849     afterPtr = afterPtr->nextPtr) {
850     tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
851     &tempLength);
852     if ((length == tempLength)
853     && (memcmp((void*) command, (void*) tempCommand,
854     (unsigned) length) == 0)) {
855     break;
856     }
857     }
858     if (afterPtr == NULL) {
859     afterPtr = GetAfterEvent(assocPtr, commandPtr);
860     }
861     if (objc != 3) {
862     Tcl_DecrRefCount(commandPtr);
863     }
864     if (afterPtr != NULL) {
865     if (afterPtr->token != NULL) {
866     Tcl_DeleteTimerHandler(afterPtr->token);
867     } else {
868     Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
869     }
870     FreeAfterPtr(afterPtr);
871     }
872     break;
873     }
874     case AFTER_IDLE:
875     if (objc < 3) {
876     Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
877     return TCL_ERROR;
878     }
879     afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
880     afterPtr->assocPtr = assocPtr;
881     if (objc == 3) {
882     afterPtr->commandPtr = objv[2];
883     } else {
884     afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
885     }
886     Tcl_IncrRefCount(afterPtr->commandPtr);
887     afterPtr->id = tsdPtr->afterId;
888     tsdPtr->afterId += 1;
889     afterPtr->token = NULL;
890     afterPtr->nextPtr = assocPtr->firstAfterPtr;
891     assocPtr->firstAfterPtr = afterPtr;
892     Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
893     sprintf(buf, "after#%d", afterPtr->id);
894     Tcl_AppendResult(interp, buf, (char *) NULL);
895     break;
896     case AFTER_INFO: {
897     Tcl_Obj *resultListPtr;
898    
899     if (objc == 2) {
900     for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
901     afterPtr = afterPtr->nextPtr) {
902     if (assocPtr->interp == interp) {
903     sprintf(buf, "after#%d", afterPtr->id);
904     Tcl_AppendElement(interp, buf);
905     }
906     }
907     return TCL_OK;
908     }
909     if (objc != 3) {
910     Tcl_WrongNumArgs(interp, 2, objv, "?id?");
911     return TCL_ERROR;
912     }
913     afterPtr = GetAfterEvent(assocPtr, objv[2]);
914     if (afterPtr == NULL) {
915     Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]),
916     "\" doesn't exist", (char *) NULL);
917     return TCL_ERROR;
918     }
919     resultListPtr = Tcl_GetObjResult(interp);
920     Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
921     Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
922     (afterPtr->token == NULL) ? "idle" : "timer", -1));
923     Tcl_SetObjResult(interp, resultListPtr);
924     break;
925     }
926     default: {
927     panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
928     }
929     }
930     return TCL_OK;
931     }
932    
933     /*
934     *----------------------------------------------------------------------
935     *
936     * GetAfterEvent --
937     *
938     * This procedure parses an "after" id such as "after#4" and
939     * returns a pointer to the AfterInfo structure.
940     *
941     * Results:
942     * The return value is either a pointer to an AfterInfo structure,
943     * if one is found that corresponds to "cmdString" and is for interp,
944     * or NULL if no corresponding after event can be found.
945     *
946     * Side effects:
947     * None.
948     *
949     *----------------------------------------------------------------------
950     */
951    
952     static AfterInfo *
953     GetAfterEvent(assocPtr, commandPtr)
954     AfterAssocData *assocPtr; /* Points to "after"-related information for
955     * this interpreter. */
956     Tcl_Obj *commandPtr;
957     {
958     char *cmdString; /* Textual identifier for after event, such
959     * as "after#6". */
960     AfterInfo *afterPtr;
961     int id;
962     char *end;
963    
964     cmdString = Tcl_GetString(commandPtr);
965     if (strncmp(cmdString, "after#", 6) != 0) {
966     return NULL;
967     }
968     cmdString += 6;
969     id = strtoul(cmdString, &end, 10);
970     if ((end == cmdString) || (*end != 0)) {
971     return NULL;
972     }
973     for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
974     afterPtr = afterPtr->nextPtr) {
975     if (afterPtr->id == id) {
976     return afterPtr;
977     }
978     }
979     return NULL;
980     }
981    
982     /*
983     *----------------------------------------------------------------------
984     *
985     * AfterProc --
986     *
987     * Timer callback to execute commands registered with the
988     * "after" command.
989     *
990     * Results:
991     * None.
992     *
993     * Side effects:
994     * Executes whatever command was specified. If the command
995     * returns an error, then the command "bgerror" is invoked
996     * to process the error; if bgerror fails then information
997     * about the error is output on stderr.
998     *
999     *----------------------------------------------------------------------
1000     */
1001    
1002     static void
1003     AfterProc(clientData)
1004     ClientData clientData; /* Describes command to execute. */
1005     {
1006     AfterInfo *afterPtr = (AfterInfo *) clientData;
1007     AfterAssocData *assocPtr = afterPtr->assocPtr;
1008     AfterInfo *prevPtr;
1009     int result;
1010     Tcl_Interp *interp;
1011     char *script;
1012     int numBytes;
1013    
1014     /*
1015     * First remove the callback from our list of callbacks; otherwise
1016     * someone could delete the callback while it's being executed, which
1017     * could cause a core dump.
1018     */
1019    
1020     if (assocPtr->firstAfterPtr == afterPtr) {
1021     assocPtr->firstAfterPtr = afterPtr->nextPtr;
1022     } else {
1023     for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
1024     prevPtr = prevPtr->nextPtr) {
1025     /* Empty loop body. */
1026     }
1027     prevPtr->nextPtr = afterPtr->nextPtr;
1028     }
1029    
1030     /*
1031     * Execute the callback.
1032     */
1033    
1034     interp = assocPtr->interp;
1035     Tcl_Preserve((ClientData) interp);
1036     script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes);
1037     result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL);
1038     if (result != TCL_OK) {
1039     Tcl_AddErrorInfo(interp, "\n (\"after\" script)");
1040     Tcl_BackgroundError(interp);
1041     }
1042     Tcl_Release((ClientData) interp);
1043    
1044     /*
1045     * Free the memory for the callback.
1046     */
1047    
1048     Tcl_DecrRefCount(afterPtr->commandPtr);
1049     ckfree((char *) afterPtr);
1050     }
1051    
1052     /*
1053     *----------------------------------------------------------------------
1054     *
1055     * FreeAfterPtr --
1056     *
1057     * This procedure removes an "after" command from the list of
1058     * those that are pending and frees its resources. This procedure
1059     * does *not* cancel the timer handler; if that's needed, the
1060     * caller must do it.
1061     *
1062     * Results:
1063     * None.
1064     *
1065     * Side effects:
1066     * The memory associated with afterPtr is released.
1067     *
1068     *----------------------------------------------------------------------
1069     */
1070    
1071     static void
1072     FreeAfterPtr(afterPtr)
1073     AfterInfo *afterPtr; /* Command to be deleted. */
1074     {
1075     AfterInfo *prevPtr;
1076     AfterAssocData *assocPtr = afterPtr->assocPtr;
1077    
1078     if (assocPtr->firstAfterPtr == afterPtr) {
1079     assocPtr->firstAfterPtr = afterPtr->nextPtr;
1080     } else {
1081     for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
1082     prevPtr = prevPtr->nextPtr) {
1083     /* Empty loop body. */
1084     }
1085     prevPtr->nextPtr = afterPtr->nextPtr;
1086     }
1087     Tcl_DecrRefCount(afterPtr->commandPtr);
1088     ckfree((char *) afterPtr);
1089     }
1090    
1091     /*
1092     *----------------------------------------------------------------------
1093     *
1094     * AfterCleanupProc --
1095     *
1096     * This procedure is invoked whenever an interpreter is deleted
1097     * to cleanup the AssocData for "tclAfter".
1098     *
1099     * Results:
1100     * None.
1101     *
1102     * Side effects:
1103     * After commands are removed.
1104     *
1105     *----------------------------------------------------------------------
1106     */
1107    
1108     /* ARGSUSED */
1109     static void
1110     AfterCleanupProc(clientData, interp)
1111     ClientData clientData; /* Points to AfterAssocData for the
1112     * interpreter. */
1113     Tcl_Interp *interp; /* Interpreter that is being deleted. */
1114     {
1115     AfterAssocData *assocPtr = (AfterAssocData *) clientData;
1116     AfterInfo *afterPtr;
1117    
1118     while (assocPtr->firstAfterPtr != NULL) {
1119     afterPtr = assocPtr->firstAfterPtr;
1120     assocPtr->firstAfterPtr = afterPtr->nextPtr;
1121     if (afterPtr->token != NULL) {
1122     Tcl_DeleteTimerHandler(afterPtr->token);
1123     } else {
1124     Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
1125     }
1126     Tcl_DecrRefCount(afterPtr->commandPtr);
1127     ckfree((char *) afterPtr);
1128     }
1129     ckfree((char *) assocPtr);
1130     }
1131    
1132    
1133     /* $History: tcltimer.c $
1134     *
1135     * ***************** Version 1 *****************
1136     * User: Dtashley Date: 1/02/01 Time: 1:05a
1137     * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
1138     * Initial check-in.
1139     */
1140    
1141     /* End of TCLTIMER.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25