2190 lines
61 KiB
C
2190 lines
61 KiB
C
/*
|
||
* 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.131 96/08/26 13:11:03
|
||
*/
|
||
|
||
#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;
|
||
/* 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.
|
||
*/
|
||
|
||
TclpGetTime(&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.
|
||
*/
|
||
|
||
TclpGetTime(&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;
|
||
}
|
||
|
||
TclpGetTime(&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)) {
|
||
TclpGetTime(&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) {
|
||
TclpGetTime(&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;
|
||
}
|
||
if (Tcl_TraceVar(interp, argv[1],
|
||
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
|
||
VwaitVarProc, (ClientData) &done) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
};
|
||
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) {
|
||
TclpGetTime(&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;
|
||
}
|
||
TclpGetTime(&now);
|
||
if ((abortTime.sec < now.sec)
|
||
|| ((abortTime.sec == now.sec)
|
||
&& (abortTime.usec <= now.usec))) {
|
||
break;
|
||
}
|
||
}
|
||
return present;
|
||
}
|