diff options
Diffstat (limited to 'contrib/tcl/generic/tclEvent.c')
| -rw-r--r-- | contrib/tcl/generic/tclEvent.c | 2187 |
1 files changed, 2187 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclEvent.c b/contrib/tcl/generic/tclEvent.c new file mode 100644 index 0000000..3c9f7d2 --- /dev/null +++ b/contrib/tcl/generic/tclEvent.c @@ -0,0 +1,2187 @@ +/* + * 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; +} |
