/* * tclEvent.c -- * * This file provides basic event-managing facilities for Tcl, * including an event queue, and mechanisms for attaching * callbacks to certain events. * * It also contains the command procedures for the commands * "after", "vwait", and "update". * * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1994-1995 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: @(#) tclEvent.c 1.127 96/03/22 12:12:33 */ #include "tclInt.h" #include "tclPort.h" /* * For each file registered in a call to Tcl_CreateFileHandler, * there is one record of the following type. All of these records * are chained together into a single list. */ typedef struct FileHandler { Tcl_File file; /* Generic file handle for file. */ int mask; /* Mask of desired events: TCL_READABLE, etc. */ int readyMask; /* Events that were ready the last time that * FileHandlerCheckProc checked this file. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. This is NULL * if the handler was created by * Tcl_CreateFileHandler2. */ ClientData clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care * about (NULL for end of list). */ } FileHandler; static FileHandler *firstFileHandlerPtr = (FileHandler *) NULL; /* List of all file handlers. */ static int fileEventSourceCreated = 0; /* Non-zero means that the file event source * hasn't been registerd with the Tcl * notifier yet. */ /* * The following structure is what is added to the Tcl event queue when * file handlers are ready to fire. */ typedef struct FileHandlerEvent { Tcl_Event header; /* Information that is standard for * all events. */ Tcl_File file; /* File descriptor that is ready. Used * to find the FileHandler structure for * the file (can't point directly to the * FileHandler structure because it could * go away while the event is queued). */ } FileHandlerEvent; /* * For each timer callback that's pending (either regular or "modal"), * 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 event so it can be * deleted. Not used in modal * timeouts. */ struct TimerHandler *nextPtr; /* Next event in queue, or NULL for * end of queue. */ } TimerHandler; static TimerHandler *firstTimerHandlerPtr = NULL; /* First event in queue. */ static int timerEventSourceCreated = 0; /* 0 means that the timer event source * hasn't yet been registered with the * Tcl notifier. */ /* * The information below describes a stack of modal timeouts managed by * Tcl_CreateModalTimer and Tcl_DeleteModalTimer. Only the first element * in the list is used at any given time. */ static TimerHandler *firstModalHandlerPtr = NULL; /* * The following structure is what's added to the Tcl event queue when * timer handlers are ready to fire. */ typedef struct TimerEvent { Tcl_Event header; /* Information that is standard for * all events. */ Tcl_Time time; /* All timer events that specify this * time or earlier are ready * to fire. */ } TimerEvent; /* * 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 = NULL; /* First in list of all idle handlers. */ static IdleHandler *lastIdlePtr = NULL; /* Last in list (or NULL for empty list). */ static int idleGeneration = 0; /* 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. */ /* * 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; /* * The data structure below is used to report background errors. One * such structure is allocated for each error; it holds information * about the interpreter and the error until bgerror can be invoked * later as an idle handler. */ typedef struct BgError { Tcl_Interp *interp; /* Interpreter in which error occurred. NULL * means this error report has been cancelled * (a previous report generated a break). */ char *errorMsg; /* The error message (interp->result when * the error occurred). Malloc-ed. */ char *errorInfo; /* Value of the errorInfo variable * (malloc-ed). */ char *errorCode; /* Value of the errorCode variable * (malloc-ed). */ struct BgError *nextPtr; /* Next in list of all pending error * reports for this interpreter, or NULL * for end of list. */ } BgError; /* * One of the structures below is associated with the "tclBgError" * assoc data for each interpreter. It keeps track of the head and * tail of the list of pending background errors for the interpreter. */ typedef struct ErrAssocData { BgError *firstBgPtr; /* First in list of all background errors * waiting to be processed for this * interpreter (NULL if none). */ BgError *lastBgPtr; /* Last in list of all background errors * waiting to be processed for this * interpreter (NULL if none). */ } ErrAssocData; /* * For each exit handler created with a call to Tcl_CreateExitHandler * there is a structure of the following type: */ typedef struct ExitHandler { Tcl_ExitProc *proc; /* Procedure to call when process exits. */ ClientData clientData; /* One word of information to pass to proc. */ struct ExitHandler *nextPtr;/* Next in list of all exit handlers for * this application, or NULL for end of list. */ } ExitHandler; static ExitHandler *firstExitPtr = NULL; /* First in list of all exit handlers for * application. */ /* * Structures of the following type are used during the execution * of Tcl_WaitForFile, to keep track of the file and timeout. */ typedef struct FileWait { Tcl_File file; /* File to wait on. */ int mask; /* Conditions to wait for (TCL_READABLE, * etc.) */ int timeout; /* Original "timeout" argument to * Tcl_WaitForFile. */ Tcl_Time abortTime; /* Time at which to abort the wait. */ int present; /* Conditions present on the file during * the last time through the event loop. */ int done; /* Non-zero means we're done: either one of * the desired conditions is present or the * timeout period has elapsed. */ } FileWait; /* * The following variable is a "secret" indication to Tcl_Exit that * it should dump out the state of memory before exiting. If the * value is non-NULL, it gives the name of the file in which to * dump memory usage information. */ char *tclMemDumpFileName = NULL; /* * 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 BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static void FileHandlerCheckProc _ANSI_ARGS_(( ClientData clientData, int flags)); static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); static void FileHandlerExitProc _ANSI_ARGS_((ClientData data)); static void FileHandlerSetupProc _ANSI_ARGS_(( ClientData clientData, int flags)); static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, char *string)); static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); static void TimerHandlerCheckProc _ANSI_ARGS_(( ClientData clientData, int flags)); static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); static void TimerHandlerExitProc _ANSI_ARGS_((ClientData data)); static void TimerHandlerSetupProc _ANSI_ARGS_(( ClientData clientData, int flags)); static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); /* *-------------------------------------------------------------- * * Tcl_CreateFileHandler -- * * Arrange for a given procedure to be invoked whenever * a given file becomes readable or writable. * * Results: * None. * * Side effects: * From now on, whenever the I/O channel given by file becomes * ready in the way indicated by mask, proc will be invoked. * See the manual entry for details on the calling sequence * to proc. If file is already registered then the old mask * and proc and clientData values will be replaced with * new ones. * *-------------------------------------------------------------- */ void Tcl_CreateFileHandler(file, mask, proc, clientData) Tcl_File file; /* Handle of stream to watch. */ int mask; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION: * indicates conditions under which * proc should be called. */ Tcl_FileProc *proc; /* Procedure to call for each * selected event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { register FileHandler *filePtr; if (!fileEventSourceCreated) { fileEventSourceCreated = 1; Tcl_CreateEventSource(FileHandlerSetupProc, FileHandlerCheckProc, (ClientData) NULL); Tcl_CreateExitHandler(FileHandlerExitProc, (ClientData) NULL); } /* * Make sure the file isn't already registered. Create a * new record in the normal case where there's no existing * record. */ for (filePtr = firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->file == file) { break; } } if (filePtr == NULL) { filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); filePtr->file = file; filePtr->nextPtr = firstFileHandlerPtr; firstFileHandlerPtr = filePtr; } /* * The remainder of the initialization below is done regardless * of whether or not this is a new record or a modification of * an old one. */ filePtr->mask = mask; filePtr->readyMask = 0; filePtr->proc = proc; filePtr->clientData = clientData; } /* *-------------------------------------------------------------- * * Tcl_DeleteFileHandler -- * * Cancel a previously-arranged callback arrangement for * a file. * * Results: * None. * * Side effects: * If a callback was previously registered on file, remove it. * *-------------------------------------------------------------- */ void Tcl_DeleteFileHandler(file) Tcl_File file; /* Stream id for which to remove * callback procedure. */ { FileHandler *filePtr, *prevPtr; /* * Find the entry for the given file (and return if there * isn't one). */ for (prevPtr = NULL, filePtr = firstFileHandlerPtr; ; prevPtr = filePtr, filePtr = filePtr->nextPtr) { if (filePtr == NULL) { return; } if (filePtr->file == file) { break; } } /* * Clean up information in the callback record. */ if (prevPtr == NULL) { firstFileHandlerPtr = filePtr->nextPtr; } else { prevPtr->nextPtr = filePtr->nextPtr; } ckfree((char *) filePtr); } /* *---------------------------------------------------------------------- * * FileHandlerExitProc -- * * Cleanup procedure to delete the file event source during exit * cleanup. * * Results: * None. * * Side effects: * Destroys the file event source. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void FileHandlerExitProc(clientData) ClientData clientData; /* Not used. */ { Tcl_DeleteEventSource(FileHandlerSetupProc, FileHandlerCheckProc, (ClientData) NULL); } /* *---------------------------------------------------------------------- * * FileHandlerSetupProc -- * * This procedure is part of the "event source" for file handlers. * It is invoked by Tcl_DoOneEvent before it calls select (or * whatever it uses to wait). * * Results: * None. * * Side effects: * Tells the notifier which files should be waited for. * *---------------------------------------------------------------------- */ static void FileHandlerSetupProc(clientData, flags) ClientData clientData; /* Not used. */ int flags; /* Flags passed to Tk_DoOneEvent: * if it doesn't include * TCL_FILE_EVENTS then we do * nothing. */ { FileHandler *filePtr; if (!(flags & TCL_FILE_EVENTS)) { return; } for (filePtr = firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->mask != 0) { Tcl_WatchFile(filePtr->file, filePtr->mask); } } } /* *---------------------------------------------------------------------- * * FileHandlerCheckProc -- * * This procedure is the second part of the "event source" for * file handlers. It is invoked by Tcl_DoOneEvent after it calls * select (or whatever it uses to wait for events). * * Results: * None. * * Side effects: * Makes entries on the Tcl event queue for each file that is * now ready. * *---------------------------------------------------------------------- */ static void FileHandlerCheckProc(clientData, flags) ClientData clientData; /* Not used. */ int flags; /* Flags passed to Tk_DoOneEvent: * if it doesn't include * TCL_FILE_EVENTS then we do * nothing. */ { FileHandler *filePtr; FileHandlerEvent *fileEvPtr; if (!(flags & TCL_FILE_EVENTS)) { return; } for (filePtr = firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->mask != 0) { filePtr->readyMask = Tcl_FileReady(filePtr->file, filePtr->mask); if (filePtr->readyMask != 0) { fileEvPtr = (FileHandlerEvent *) ckalloc( sizeof(FileHandlerEvent)); fileEvPtr->header.proc = FileHandlerEventProc; fileEvPtr->file = filePtr->file; Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); } } } } /* *---------------------------------------------------------------------- * * FileHandlerEventProc -- * * This procedure is called by Tcl_DoOneEvent when a file event * reaches the front of the event queue. This procedure is responsible * for actually handling the event by invoking the callback for the * file handler. * * 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_FILE_EVENTS flag bit isn't set. * * Side effects: * Whatever the file handler's callback procedure does * *---------------------------------------------------------------------- */ static int FileHandlerEventProc(evPtr, flags) Tcl_Event *evPtr; /* Event to service. */ int flags; /* Flags that indicate what events to * handle, such as TCL_FILE_EVENTS. */ { FileHandler *filePtr; FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; int mask; if (!(flags & TCL_FILE_EVENTS)) { return 0; } /* * Search through the file handlers to find the one whose handle matches * the event. We do this rather than keeping a pointer to the file * handler directly in the event, so that the handler can be deleted * while the event is queued without leaving a dangling pointer. */ for (filePtr = firstFileHandlerPtr; filePtr != NULL; filePtr = filePtr->nextPtr) { if (filePtr->file != fileEvPtr->file) { continue; } /* * The code is tricky for two reasons: * 1. The file handler's desired events could have changed * since the time when the event was queued, so AND the * ready mask with the desired mask. * 2. The file could have been closed and re-opened since * the time when the event was queued. This is why the * ready mask is stored in the file handler rather than * the queued event: it will be zeroed when a new * file handler is created for the newly opened file. */ mask = filePtr->readyMask & filePtr->mask; filePtr->readyMask = 0; if (mask != 0) { (*filePtr->proc)(filePtr->clientData, mask); } break; } return 1; } /* *-------------------------------------------------------------- * * 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; static int id = 0; if (!timerEventSourceCreated) { timerEventSourceCreated = 1; Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, (ClientData) NULL); Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); } timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); /* * Compute when the event should fire. */ TclGetTime(&timerHandlerPtr->time); timerHandlerPtr->time.sec += milliseconds/1000; timerHandlerPtr->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; id++; timerHandlerPtr->token = (Tcl_TimerToken) id; /* * 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; } 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; } } /* *-------------------------------------------------------------- * * Tcl_CreateModalTimeout -- * * Arrange for a given procedure to be invoked at a particular * time in the future, independently of all other timer events. * * Results: * None. * * Side effects: * When milliseconds have elapsed, proc will be invoked * exactly once. * *-------------------------------------------------------------- */ void Tcl_CreateModalTimeout(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. */ { TimerHandler *timerHandlerPtr; if (!timerEventSourceCreated) { timerEventSourceCreated = 1; Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, (ClientData) NULL); Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); } timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); /* * Compute when the timeout should fire and fill in the other fields * of the handler. */ TclGetTime(&timerHandlerPtr->time); timerHandlerPtr->time.sec += milliseconds/1000; timerHandlerPtr->time.usec += (milliseconds%1000)*1000; if (timerHandlerPtr->time.usec >= 1000000) { timerHandlerPtr->time.usec -= 1000000; timerHandlerPtr->time.sec += 1; } timerHandlerPtr->proc = proc; timerHandlerPtr->clientData = clientData; /* * Push the handler on the top of the modal stack. */ timerHandlerPtr->nextPtr = firstModalHandlerPtr; firstModalHandlerPtr = timerHandlerPtr; } /* *-------------------------------------------------------------- * * Tcl_DeleteModalTimeout -- * * Remove the topmost modal timer handler from the stack of * modal handlers. * * Results: * None. * * Side effects: * Destroys the topmost modal timeout handler, which must * match proc and clientData. * *-------------------------------------------------------------- */ void Tcl_DeleteModalTimeout(proc, clientData) Tcl_TimerProc *proc; /* Callback procedure for the timeout. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { TimerHandler *timerHandlerPtr; timerHandlerPtr = firstModalHandlerPtr; firstModalHandlerPtr = timerHandlerPtr->nextPtr; if ((timerHandlerPtr->proc != proc) || (timerHandlerPtr->clientData != clientData)) { panic("Tcl_DeleteModalTimeout found timeout stack corrupted"); } ckfree((char *) timerHandlerPtr); } /* *---------------------------------------------------------------------- * * TimerHandlerSetupProc -- * * This procedure is part of the "event source" for timers. * It is invoked by Tcl_DoOneEvent before it calls select (or * whatever it uses to wait). * * Results: * None. * * Side effects: * Tells the notifier how long to sleep if it decides to block. * *---------------------------------------------------------------------- */ static void TimerHandlerSetupProc(clientData, flags) ClientData clientData; /* Not used. */ int flags; /* Flags passed to Tk_DoOneEvent: * if it doesn't include * TCL_TIMER_EVENTS then we only * consider modal timers. */ { TimerHandler *timerHandlerPtr, *tPtr2; Tcl_Time blockTime; /* * Find the timer handler (regular or modal) that fires first. */ timerHandlerPtr = firstTimerHandlerPtr; if (!(flags & TCL_TIMER_EVENTS)) { timerHandlerPtr = NULL; } if (timerHandlerPtr != NULL) { tPtr2 = firstModalHandlerPtr; if (tPtr2 != NULL) { if ((timerHandlerPtr->time.sec > tPtr2->time.sec) || ((timerHandlerPtr->time.sec == tPtr2->time.sec) && (timerHandlerPtr->time.usec > tPtr2->time.usec))) { timerHandlerPtr = tPtr2; } } } else { timerHandlerPtr = firstModalHandlerPtr; } if (timerHandlerPtr == NULL) { return; } TclGetTime(&blockTime); blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec; blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec; if (blockTime.usec < 0) { blockTime.sec -= 1; blockTime.usec += 1000000; } if (blockTime.sec < 0) { blockTime.sec = 0; blockTime.usec = 0; } Tcl_SetMaxBlockTime(&blockTime); } /* *---------------------------------------------------------------------- * * TimerHandlerCheckProc -- * * This procedure is the second part of the "event source" for * file handlers. It is invoked by Tcl_DoOneEvent after it calls * select (or whatever it uses to wait for events). * * Results: * None. * * Side effects: * Makes entries on the Tcl event queue for each file that is * now ready. * *---------------------------------------------------------------------- */ static void TimerHandlerCheckProc(clientData, flags) ClientData clientData; /* Not used. */ int flags; /* Flags passed to Tk_DoOneEvent: * if it doesn't include * TCL_TIMER_EVENTS then we only * consider modal timeouts. */ { TimerHandler *timerHandlerPtr; TimerEvent *timerEvPtr; int triggered, gotTime; Tcl_Time curTime; triggered = 0; gotTime = 0; timerHandlerPtr = firstTimerHandlerPtr; if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) { TclGetTime(&curTime); gotTime = 1; if ((timerHandlerPtr->time.sec < curTime.sec) || ((timerHandlerPtr->time.sec == curTime.sec) && (timerHandlerPtr->time.usec <= curTime.usec))) { triggered = 1; } } timerHandlerPtr = firstModalHandlerPtr; if (timerHandlerPtr != NULL) { if (!gotTime) { TclGetTime(&curTime); } if ((timerHandlerPtr->time.sec < curTime.sec) || ((timerHandlerPtr->time.sec == curTime.sec) && (timerHandlerPtr->time.usec <= curTime.usec))) { triggered = 1; } } if (triggered) { timerEvPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent)); timerEvPtr->header.proc = TimerHandlerEventProc; timerEvPtr->time.sec = curTime.sec; timerEvPtr->time.usec = curTime.usec; Tcl_QueueEvent((Tcl_Event *) timerEvPtr, TCL_QUEUE_TAIL); } } /* *---------------------------------------------------------------------- * * TimerHandlerExitProc -- * * Callback invoked during exit cleanup to destroy the timer event * source. * * Results: * None. * * Side effects: * Destroys the timer event source. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TimerHandlerExitProc(clientData) ClientData clientData; /* Not used. */ { Tcl_DeleteEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, (ClientData) NULL); } /* *---------------------------------------------------------------------- * * TimerHandlerEventProc -- * * This procedure is called by Tcl_DoOneEvent 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; TimerEvent *timerEvPtr = (TimerEvent *) evPtr; /* * Invoke the current modal timeout first, if there is one and * it has triggered. */ timerHandlerPtr = firstModalHandlerPtr; if (firstModalHandlerPtr != NULL) { if ((timerHandlerPtr->time.sec < timerEvPtr->time.sec) || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) && (timerHandlerPtr->time.usec <= timerEvPtr->time.usec))) { (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); } } /* * Invoke any normal timers that have fired. */ if (!(flags & TCL_TIMER_EVENTS)) { return 1; } while (1) { timerHandlerPtr = firstTimerHandlerPtr; if (timerHandlerPtr == NULL) { break; } if ((timerHandlerPtr->time.sec > timerEvPtr->time.sec) || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) && (timerHandlerPtr->time.usec >= timerEvPtr->time.usec))) { break; } /* * Remove the handler from the queue before invoking it, * to avoid potential reentrancy problems. */ firstTimerHandlerPtr = timerHandlerPtr->nextPtr; (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); ckfree((char *) timerHandlerPtr); } 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; 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; } /* *---------------------------------------------------------------------- * * 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; } } } } /* *---------------------------------------------------------------------- * * TclIdlePending -- * * This function is called by the notifier subsystem to determine * whether there are any idle handlers currently scheduled. * * Results: * Returns 0 if the idle list is empty, otherwise it returns 1. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclIdlePending() { return (idleList == NULL) ? 0 : 1; } /* *---------------------------------------------------------------------- * * TclServiceIdle -- * * This procedure is invoked by the notifier when it becomes idle. * * Results: * The return value is 1 if the procedure actually found an idle * handler to invoke. If no handler was found then 0 is returned. * * Side effects: * Invokes all pending idle handlers. * *---------------------------------------------------------------------- */ int TclServiceIdle() { IdleHandler *idlePtr; int oldGeneration; int foundIdle; if (idleList == NULL) { return 0; } foundIdle = 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; } foundIdle = 1; (*idlePtr->proc)(idlePtr->clientData); ckfree((char *) idlePtr); } return foundIdle; } /* *---------------------------------------------------------------------- * * Tcl_BackgroundError -- * * This procedure is invoked to handle errors that occur in Tcl * commands that are invoked in "background" (e.g. from event or * timer bindings). * * Results: * None. * * Side effects: * The command "bgerror" is invoked later as an idle handler to * process the error, passing it the error message. If that fails, * then an error message is output on stderr. * *---------------------------------------------------------------------- */ void Tcl_BackgroundError(interp) Tcl_Interp *interp; /* Interpreter in which an error has * occurred. */ { BgError *errPtr; char *varValue; ErrAssocData *assocPtr; /* * The Tcl_AddErrorInfo call below (with an empty string) ensures that * errorInfo gets properly set. It's needed in cases where the error * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval; * in these cases errorInfo still won't have been set when this * procedure is called. */ Tcl_AddErrorInfo(interp, ""); errPtr = (BgError *) ckalloc(sizeof(BgError)); errPtr->interp = interp; errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result) + 1)); strcpy(errPtr->errorMsg, interp->result); varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (varValue == NULL) { varValue = errPtr->errorMsg; } errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); strcpy(errPtr->errorInfo, varValue); varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); if (varValue == NULL) { varValue = ""; } errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); strcpy(errPtr->errorCode, varValue); errPtr->nextPtr = NULL; assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", (Tcl_InterpDeleteProc **) NULL); if (assocPtr == NULL) { /* * This is the first time a background error has occurred in * this interpreter. Create associated data to keep track of * pending error reports. */ assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); assocPtr->firstBgPtr = NULL; assocPtr->lastBgPtr = NULL; Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, (ClientData) assocPtr); } if (assocPtr->firstBgPtr == NULL) { assocPtr->firstBgPtr = errPtr; Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); } else { assocPtr->lastBgPtr->nextPtr = errPtr; } assocPtr->lastBgPtr = errPtr; Tcl_ResetResult(interp); } /* *---------------------------------------------------------------------- * * HandleBgErrors -- * * This procedure is invoked as an idle handler to process all of * the accumulated background errors. * * Results: * None. * * Side effects: * Depends on what actions "bgerror" takes for the errors. * *---------------------------------------------------------------------- */ static void HandleBgErrors(clientData) ClientData clientData; /* Pointer to ErrAssocData structure. */ { Tcl_Interp *interp; char *command; char *argv[2]; int code; BgError *errPtr; ErrAssocData *assocPtr = (ErrAssocData *) clientData; Tcl_Channel errChannel; while (assocPtr->firstBgPtr != NULL) { interp = assocPtr->firstBgPtr->interp; if (interp == NULL) { goto doneWithReport; } /* * Restore important state variables to what they were at * the time the error occurred. */ Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode, TCL_GLOBAL_ONLY); /* * Create and invoke the bgerror command. */ argv[0] = "bgerror"; argv[1] = assocPtr->firstBgPtr->errorMsg; command = Tcl_Merge(2, argv); Tcl_AllowExceptions(interp); Tcl_Preserve((ClientData) interp); code = Tcl_GlobalEval(interp, command); ckfree(command); if (code == TCL_ERROR) { /* * We have to get the error output channel at the latest possible * time, because the eval (above) might have changed the channel. */ errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { if (strcmp(interp->result, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) { Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1); Tcl_Write(errChannel, "\n", -1); } else { Tcl_Write(errChannel, "bgerror failed to handle background error.\n", -1); Tcl_Write(errChannel, " Original error: ", -1); Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg, -1); Tcl_Write(errChannel, "\n", -1); Tcl_Write(errChannel, " Error in bgerror: ", -1); Tcl_Write(errChannel, interp->result, -1); Tcl_Write(errChannel, "\n", -1); } Tcl_Flush(errChannel); } } else if (code == TCL_BREAK) { /* * Break means cancel any remaining error reports for this * interpreter. */ for (errPtr = assocPtr->firstBgPtr; errPtr != NULL; errPtr = errPtr->nextPtr) { if (errPtr->interp == interp) { errPtr->interp = NULL; } } } Tcl_Release((ClientData) interp); /* * Discard the command and the information about the error report. */ doneWithReport: ckfree(assocPtr->firstBgPtr->errorMsg); ckfree(assocPtr->firstBgPtr->errorInfo); ckfree(assocPtr->firstBgPtr->errorCode); errPtr = assocPtr->firstBgPtr->nextPtr; ckfree((char *) assocPtr->firstBgPtr); assocPtr->firstBgPtr = errPtr; } assocPtr->lastBgPtr = NULL; } /* *---------------------------------------------------------------------- * * BgErrorDeleteProc -- * * This procedure is associated with the "tclBgError" assoc data * for an interpreter; it is invoked when the interpreter is * deleted in order to free the information assoicated with any * pending error reports. * * Results: * None. * * Side effects: * Background error information is freed: if there were any * pending error reports, they are cancelled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc(clientData, interp) ClientData clientData; /* Pointer to ErrAssocData structure. */ Tcl_Interp *interp; /* Interpreter being deleted. */ { ErrAssocData *assocPtr = (ErrAssocData *) clientData; BgError *errPtr; while (assocPtr->firstBgPtr != NULL) { errPtr = assocPtr->firstBgPtr; assocPtr->firstBgPtr = errPtr->nextPtr; ckfree(errPtr->errorMsg); ckfree(errPtr->errorInfo); ckfree(errPtr->errorCode); ckfree((char *) errPtr); } ckfree((char *) assocPtr); Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); } /* *---------------------------------------------------------------------- * * Tcl_CreateExitHandler -- * * Arrange for a given procedure to be invoked just before the * application exits. * * Results: * None. * * Side effects: * Proc will be invoked with clientData as argument when the * application exits. * *---------------------------------------------------------------------- */ void Tcl_CreateExitHandler(proc, clientData) Tcl_ExitProc *proc; /* Procedure to invoke. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = firstExitPtr; firstExitPtr = exitPtr; } /* *---------------------------------------------------------------------- * * Tcl_DeleteExitHandler -- * * This procedure cancels an existing exit handler matching proc * and clientData, if such a handler exits. * * Results: * None. * * Side effects: * If there is an exit handler corresponding to proc and clientData * then it is cancelled; if no such handler exists then nothing * happens. * *---------------------------------------------------------------------- */ void Tcl_DeleteExitHandler(proc, clientData) Tcl_ExitProc *proc; /* Procedure that was previously registered. */ ClientData clientData; /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { if ((exitPtr->proc == proc) && (exitPtr->clientData == clientData)) { if (prevPtr == NULL) { firstExitPtr = exitPtr->nextPtr; } else { prevPtr->nextPtr = exitPtr->nextPtr; } ckfree((char *) exitPtr); return; } } } /* *---------------------------------------------------------------------- * * Tcl_Exit -- * * This procedure is called to terminate the application. * * Results: * None. * * Side effects: * All existing exit handlers are invoked, then the application * ends. * *---------------------------------------------------------------------- */ void Tcl_Exit(status) int status; /* Exit status for application; typically * 0 for normal return, 1 for error return. */ { ExitHandler *exitPtr; for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* * Be careful to remove the handler from the list before invoking * its callback. This protects us against double-freeing if the * callback should call Tcl_DeleteExitHandler on itself. */ firstExitPtr = exitPtr->nextPtr; (*exitPtr->proc)(exitPtr->clientData); ckfree((char *) exitPtr); } #ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_DumpActiveMemory(tclMemDumpFileName); } #endif TclPlatformExit(status); } /* *---------------------------------------------------------------------- * * Tcl_AfterCmd -- * * 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_AfterCmd(clientData, interp, argc, argv) 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 argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { /* * 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; size_t length; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg ...?\"", (char *) NULL); 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 = Tcl_AfterCmd; cmdInfo.clientData = (ClientData) assocPtr; cmdInfo.deleteProc = NULL; cmdInfo.deleteData = (ClientData) assocPtr; Tcl_SetCommandInfo(interp, argv[0], &cmdInfo); } /* * Parse the command. */ length = strlen(argv[1]); if (isdigit(UCHAR(argv[1][0]))) { if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) { return TCL_ERROR; } if (ms < 0) { ms = 0; } if (argc == 2) { Tcl_Sleep(ms); return TCL_OK; } afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (argc == 3) { afterPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); strcpy(afterPtr->command, argv[2]); } else { afterPtr->command = Tcl_Concat(argc-2, argv+2); } 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); } else if (strncmp(argv[1], "cancel", length) == 0) { char *arg; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " cancel id|command\"", (char *) NULL); return TCL_ERROR; } if (argc == 3) { arg = argv[2]; } else { arg = Tcl_Concat(argc-2, argv+2); } for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (strcmp(afterPtr->command, arg) == 0) { break; } } if (afterPtr == NULL) { afterPtr = GetAfterEvent(assocPtr, arg); } if (arg != argv[2]) { ckfree(arg); } if (afterPtr != NULL) { if (afterPtr->token != NULL) { Tcl_DeleteTimerHandler(afterPtr->token); } else { Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } FreeAfterPtr(afterPtr); } } else if ((strncmp(argv[1], "idle", length) == 0) && (length >= 2)) { if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " idle script script ...\"", (char *) NULL); return TCL_ERROR; } afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (argc == 3) { afterPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); strcpy(afterPtr->command, argv[2]); } else { afterPtr->command = Tcl_Concat(argc-2, argv+2); } 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); } else if ((strncmp(argv[1], "info", length) == 0) && (length >= 2)) { if (argc == 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 (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " info ?id?\"", (char *) NULL); return TCL_ERROR; } afterPtr = GetAfterEvent(assocPtr, argv[2]); if (afterPtr == NULL) { Tcl_AppendResult(interp, "event \"", argv[2], "\" doesn't exist", (char *) NULL); return TCL_ERROR; } Tcl_AppendElement(interp, afterPtr->command); Tcl_AppendElement(interp, (afterPtr->token == NULL) ? "idle" : "timer"); } else { Tcl_AppendResult(interp, "bad argument \"", argv[1], "\": must be cancel, idle, info, or a number", (char *) NULL); return TCL_ERROR; } 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); } /* *---------------------------------------------------------------------- * * Tcl_VwaitCmd -- * * This procedure is invoked to process the "vwait" 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_VwaitCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int done, foundEvent; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " name\"", (char *) NULL); return TCL_ERROR; } Tcl_TraceVar(interp, argv[1], TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); done = 0; foundEvent = 1; while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(0); } Tcl_UntraceVar(interp, argv[1], TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); /* * Clear out the interpreter's result, since it may have been set * by event handlers. */ Tcl_ResetResult(interp); if (!foundEvent) { Tcl_AppendResult(interp, "can't wait for variable \"", argv[1], "\": would wait forever", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* ARGSUSED */ static char * VwaitVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Pointer to integer to set to 1. */ Tcl_Interp *interp; /* Interpreter containing variable. */ char *name1; /* Name of variable. */ char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ { int *donePtr = (int *) clientData; *donePtr = 1; return (char *) NULL; } /* *---------------------------------------------------------------------- * * Tcl_UpdateCmd -- * * This procedure is invoked to process the "update" 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_UpdateCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int flags = 0; /* Initialization needed only to stop * compiler warnings. */ if (argc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (argc == 2) { if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be idletasks", (char *) NULL); return TCL_ERROR; } flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?idletasks?\"", (char *) NULL); return TCL_ERROR; } while (Tcl_DoOneEvent(flags) != 0) { /* Empty loop body */ } /* * Must clear the interpreter's result because event handlers could * have executed commands. */ Tcl_ResetResult(interp); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclWaitForFile -- * * This procedure waits synchronously for a file to become readable * or writable, with an optional timeout. * * Results: * The return value is an OR'ed combination of TCL_READABLE, * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions * that are present on file at the time of the return. This * procedure will not return until either "timeout" milliseconds * have elapsed or at least one of the conditions given by mask * has occurred for file (a return value of 0 means that a timeout * occurred). No normal events will be serviced during the * execution of this procedure. * * Side effects: * Time passes. * *---------------------------------------------------------------------- */ int TclWaitForFile(file, mask, timeout) Tcl_File file; /* Handle for file on which to wait. */ int mask; /* What to wait for: OR'ed combination of * TCL_READABLE, TCL_WRITABLE, and * TCL_EXCEPTION. */ int timeout; /* Maximum amount of time to wait for one * of the conditions in mask to occur, in * milliseconds. A value of 0 means don't * wait at all, and a value of -1 means * wait forever. */ { Tcl_Time abortTime, now, blockTime; int present; /* * If there is a non-zero finite timeout, compute the time when * we give up. */ if (timeout > 0) { TclGetTime(&now); abortTime.sec = now.sec + timeout/1000; abortTime.usec = now.usec + (timeout%1000)*1000; if (abortTime.usec >= 1000000) { abortTime.usec -= 1000000; abortTime.sec += 1; } } /* * Loop in a mini-event loop of our own, waiting for either the * file to become ready or a timeout to occur. */ while (1) { Tcl_WatchFile(file, mask); if (timeout > 0) { blockTime.sec = abortTime.sec - now.sec; blockTime.usec = abortTime.usec - now.usec; if (blockTime.usec < 0) { blockTime.sec -= 1; blockTime.usec += 1000000; } if (blockTime.sec < 0) { blockTime.sec = 0; blockTime.usec = 0; } Tcl_WaitForEvent(&blockTime); } else if (timeout == 0) { blockTime.sec = 0; blockTime.usec = 0; Tcl_WaitForEvent(&blockTime); } else { Tcl_WaitForEvent((Tcl_Time *) NULL); } present = Tcl_FileReady(file, mask); if (present != 0) { break; } if (timeout == 0) { break; } TclGetTime(&now); if ((abortTime.sec < now.sec) || ((abortTime.sec == now.sec) && (abortTime.usec <= now.usec))) { break; } } return present; }