home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclEvent.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  62KB  |  2,188 lines
  1. /* 
  2.  * tclEvent.c --
  3.  *
  4.  *    This file provides basic event-managing facilities for Tcl,
  5.  *    including an event queue, and mechanisms for attaching
  6.  *    callbacks to certain events.
  7.  *
  8.  *    It also contains the command procedures for the commands
  9.  *    "after", "vwait", and "update".
  10.  *
  11.  * Copyright (c) 1990-1994 The Regents of the University of California.
  12.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  13.  *
  14.  * See the file "license.terms" for information on usage and redistribution
  15.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16.  *
  17.  * SCCS: @(#) tclEvent.c 1.127 96/03/22 12:12:33
  18.  */
  19.  
  20. #include "tclInt.h"
  21. #include "tclPort.h"
  22.  
  23. /*
  24.  * For each file registered in a call to Tcl_CreateFileHandler,
  25.  * there is one record of the following type.  All of these records
  26.  * are chained together into a single list.
  27.  */
  28.  
  29. typedef struct FileHandler {
  30.     Tcl_File file;        /* Generic file handle for file. */
  31.     int mask;            /* Mask of desired events: TCL_READABLE, etc. */
  32.     int readyMask;        /* Events that were ready the last time that
  33.                  * FileHandlerCheckProc checked this file. */
  34.     Tcl_FileProc *proc;        /* Procedure to call, in the style of
  35.                  * Tcl_CreateFileHandler.  This is NULL
  36.                  * if the handler was created by
  37.                  * Tcl_CreateFileHandler2. */
  38.     ClientData clientData;    /* Argument to pass to proc. */
  39.     struct FileHandler *nextPtr;/* Next in list of all files we care
  40.                  * about (NULL for end of list). */
  41. } FileHandler;
  42.  
  43. static FileHandler *firstFileHandlerPtr = (FileHandler *) NULL;
  44.                 /* List of all file handlers. */
  45. static int fileEventSourceCreated = 0;
  46.                 /* Non-zero means that the file event source
  47.                  * hasn't been registerd with the Tcl
  48.                  * notifier yet. */
  49.  
  50. /*
  51.  * The following structure is what is added to the Tcl event queue when
  52.  * file handlers are ready to fire.
  53.  */
  54.  
  55. typedef struct FileHandlerEvent {
  56.     Tcl_Event header;        /* Information that is standard for
  57.                  * all events. */
  58.     Tcl_File file;        /* File descriptor that is ready.  Used
  59.                  * to find the FileHandler structure for
  60.                  * the file (can't point directly to the
  61.                  * FileHandler structure because it could
  62.                  * go away while the event is queued). */
  63. } FileHandlerEvent;
  64.  
  65. /*
  66.  * For each timer callback that's pending (either regular or "modal"),
  67.  * there is one record of the following type.  The normal handlers
  68.  * (created by Tcl_CreateTimerHandler) are chained together in a
  69.  * list sorted by time (earliest event first).
  70.  */
  71.  
  72. typedef struct TimerHandler {
  73.     Tcl_Time time;            /* When timer is to fire. */
  74.     Tcl_TimerProc *proc;        /* Procedure to call. */
  75.     ClientData clientData;        /* Argument to pass to proc. */
  76.     Tcl_TimerToken token;        /* Identifies event so it can be
  77.                      * deleted.  Not used in modal
  78.                      * timeouts. */
  79.     struct TimerHandler *nextPtr;    /* Next event in queue, or NULL for
  80.                      * end of queue. */
  81. } TimerHandler;
  82.  
  83. static TimerHandler *firstTimerHandlerPtr = NULL;
  84.                     /* First event in queue. */
  85. static int timerEventSourceCreated = 0;    /* 0 means that the timer event source
  86.                      * hasn't yet been registered with the
  87.                      * Tcl notifier. */
  88.  
  89. /*
  90.  * The information below describes a stack of modal timeouts managed by
  91.  * Tcl_CreateModalTimer and Tcl_DeleteModalTimer.  Only the first element
  92.  * in the list is used at any given time.
  93.  */
  94.  
  95. static TimerHandler *firstModalHandlerPtr = NULL;
  96.  
  97. /*
  98.  * The following structure is what's added to the Tcl event queue when
  99.  * timer handlers are ready to fire.
  100.  */
  101.  
  102. typedef struct TimerEvent {
  103.     Tcl_Event header;            /* Information that is standard for
  104.                      * all events. */
  105.     Tcl_Time time;            /* All timer events that specify this
  106.                      * time or earlier are ready
  107.                                          * to fire. */
  108. } TimerEvent;
  109.  
  110. /*
  111.  * There is one of the following structures for each of the
  112.  * handlers declared in a call to Tcl_DoWhenIdle.  All of the
  113.  * currently-active handlers are linked together into a list.
  114.  */
  115.  
  116. typedef struct IdleHandler {
  117.     Tcl_IdleProc (*proc);    /* Procedure to call. */
  118.     ClientData clientData;    /* Value to pass to proc. */
  119.     int generation;        /* Used to distinguish older handlers from
  120.                  * recently-created ones. */
  121.     struct IdleHandler *nextPtr;/* Next in list of active handlers. */
  122. } IdleHandler;
  123.  
  124. static IdleHandler *idleList = NULL;
  125.                 /* First in list of all idle handlers. */
  126. static IdleHandler *lastIdlePtr = NULL;
  127.                 /* Last in list (or NULL for empty list). */
  128. static int idleGeneration = 0;    /* Used to fill in the "generation" fields
  129.                  * of IdleHandler structures.  Increments
  130.                  * each time Tcl_DoOneEvent starts calling
  131.                  * idle handlers, so that all old handlers
  132.                  * can be called without calling any of the
  133.                  * new ones created by old ones. */
  134.  
  135. /*
  136.  * The data structure below is used by the "after" command to remember
  137.  * the command to be executed later.  All of the pending "after" commands
  138.  * for an interpreter are linked together in a list.
  139.  */
  140.  
  141. typedef struct AfterInfo {
  142.     struct AfterAssocData *assocPtr;
  143.                 /* Pointer to the "tclAfter" assocData for
  144.                  * the interp in which command will be
  145.                  * executed. */
  146.     char *command;        /* Command to execute.  Malloc'ed, so must
  147.                  * be freed when structure is deallocated. */
  148.     int id;            /* Integer identifier for command;  used to
  149.                  * cancel it. */
  150.     Tcl_TimerToken token;    /* Used to cancel the "after" command.  NULL
  151.                  * means that the command is run as an
  152.                  * idle handler rather than as a timer
  153.                  * handler.  NULL means this is an "after
  154.                  * idle" handler rather than a
  155.                                  * timer handler. */
  156.     struct AfterInfo *nextPtr;    /* Next in list of all "after" commands for
  157.                  * this interpreter. */
  158. } AfterInfo;
  159.  
  160. /*
  161.  * One of the following structures is associated with each interpreter
  162.  * for which an "after" command has ever been invoked.  A pointer to
  163.  * this structure is stored in the AssocData for the "tclAfter" key.
  164.  */
  165.  
  166. typedef struct AfterAssocData {
  167.     Tcl_Interp *interp;        /* The interpreter for which this data is
  168.                  * registered. */
  169.     AfterInfo *firstAfterPtr;    /* First in list of all "after" commands
  170.                  * still pending for this interpreter, or
  171.                  * NULL if none. */
  172. } AfterAssocData;
  173.  
  174. /*
  175.  * The data structure below is used to report background errors.  One
  176.  * such structure is allocated for each error;  it holds information
  177.  * about the interpreter and the error until bgerror can be invoked
  178.  * later as an idle handler.
  179.  */
  180.  
  181. typedef struct BgError {
  182.     Tcl_Interp *interp;        /* Interpreter in which error occurred.  NULL
  183.                  * means this error report has been cancelled
  184.                  * (a previous report generated a break). */
  185.     char *errorMsg;        /* The error message (interp->result when
  186.                  * the error occurred).  Malloc-ed. */
  187.     char *errorInfo;        /* Value of the errorInfo variable
  188.                  * (malloc-ed). */
  189.     char *errorCode;        /* Value of the errorCode variable
  190.                  * (malloc-ed). */
  191.     struct BgError *nextPtr;    /* Next in list of all pending error
  192.                  * reports for this interpreter, or NULL
  193.                  * for end of list. */
  194. } BgError;
  195.  
  196. /*
  197.  * One of the structures below is associated with the "tclBgError"
  198.  * assoc data for each interpreter.  It keeps track of the head and
  199.  * tail of the list of pending background errors for the interpreter.
  200.  */
  201.  
  202. typedef struct ErrAssocData {
  203.     BgError *firstBgPtr;    /* First in list of all background errors
  204.                  * waiting to be processed for this
  205.                  * interpreter (NULL if none). */
  206.     BgError *lastBgPtr;        /* Last in list of all background errors
  207.                  * waiting to be processed for this
  208.                  * interpreter (NULL if none). */
  209. } ErrAssocData;
  210.  
  211. /*
  212.  * For each exit handler created with a call to Tcl_CreateExitHandler
  213.  * there is a structure of the following type:
  214.  */
  215.  
  216. typedef struct ExitHandler {
  217.     Tcl_ExitProc *proc;        /* Procedure to call when process exits. */
  218.     ClientData clientData;    /* One word of information to pass to proc. */
  219.     struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
  220.                  * this application, or NULL for end of list. */
  221. } ExitHandler;
  222.  
  223. static ExitHandler *firstExitPtr = NULL;
  224.                 /* First in list of all exit handlers for
  225.                  * application. */
  226.  
  227. /*
  228.  * Structures of the following type are used during the execution
  229.  * of Tcl_WaitForFile, to keep track of the file and timeout.
  230.  */
  231.  
  232. typedef struct FileWait {
  233.     Tcl_File file;        /* File to wait on. */
  234.     int mask;            /* Conditions to wait for (TCL_READABLE,
  235.                  * etc.) */
  236.     int timeout;        /* Original "timeout" argument to
  237.                  * Tcl_WaitForFile. */
  238.     Tcl_Time abortTime;        /* Time at which to abort the wait. */
  239.     int present;        /* Conditions present on the file during
  240.                  * the last time through the event loop. */
  241.     int done;            /* Non-zero means we're done:  either one of
  242.                  * the desired conditions is present or the
  243.                  * timeout period has elapsed. */
  244. } FileWait;
  245.  
  246. /*
  247.  * The following variable is a "secret" indication to Tcl_Exit that
  248.  * it should dump out the state of memory before exiting.  If the
  249.  * value is non-NULL, it gives the name of the file in which to
  250.  * dump memory usage information.
  251.  */
  252.  
  253. char *tclMemDumpFileName = NULL;
  254.  
  255. /*
  256.  * Prototypes for procedures referenced only in this file:
  257.  */
  258.  
  259. static void        AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
  260.                 Tcl_Interp *interp));
  261. static void        AfterProc _ANSI_ARGS_((ClientData clientData));
  262. static void        BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
  263.                 Tcl_Interp *interp));
  264. static void        FileHandlerCheckProc _ANSI_ARGS_((
  265.                 ClientData clientData, int flags));
  266. static int        FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
  267.                 int flags));
  268. static void        FileHandlerExitProc _ANSI_ARGS_((ClientData data));
  269. static void        FileHandlerSetupProc _ANSI_ARGS_((
  270.                 ClientData clientData, int flags));
  271. static void        FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
  272. static AfterInfo *    GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
  273.                 char *string));
  274. static void        HandleBgErrors _ANSI_ARGS_((ClientData clientData));
  275. static void        TimerHandlerCheckProc _ANSI_ARGS_((
  276.                 ClientData clientData, int flags));
  277. static int        TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
  278.                 int flags));
  279. static void        TimerHandlerExitProc _ANSI_ARGS_((ClientData data));
  280. static void        TimerHandlerSetupProc _ANSI_ARGS_((
  281.                 ClientData clientData, int flags));
  282. static char *        VwaitVarProc _ANSI_ARGS_((ClientData clientData,
  283.                 Tcl_Interp *interp, char *name1, char *name2,
  284.                 int flags));
  285.  
  286. /*
  287.  *--------------------------------------------------------------
  288.  *
  289.  * Tcl_CreateFileHandler --
  290.  *
  291.  *    Arrange for a given procedure to be invoked whenever
  292.  *    a given file becomes readable or writable.
  293.  *
  294.  * Results:
  295.  *    None.
  296.  *
  297.  * Side effects:
  298.  *    From now on, whenever the I/O channel given by file becomes
  299.  *    ready in the way indicated by mask, proc will be invoked.
  300.  *    See the manual entry for details on the calling sequence
  301.  *    to proc.  If file is already registered then the old mask
  302.  *    and proc and clientData values will be replaced with
  303.  *    new ones.
  304.  *
  305.  *--------------------------------------------------------------
  306.  */
  307.  
  308. void
  309. Tcl_CreateFileHandler(file, mask, proc, clientData)
  310.     Tcl_File file;        /* Handle of stream to watch. */
  311.     int mask;            /* OR'ed combination of TCL_READABLE,
  312.                  * TCL_WRITABLE, and TCL_EXCEPTION:
  313.                  * indicates conditions under which
  314.                  * proc should be called. */
  315.     Tcl_FileProc *proc;        /* Procedure to call for each
  316.                  * selected event. */
  317.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  318. {
  319.     register FileHandler *filePtr;
  320.  
  321.     if (!fileEventSourceCreated) {
  322.     fileEventSourceCreated = 1;
  323.     Tcl_CreateEventSource(FileHandlerSetupProc, FileHandlerCheckProc,
  324.         (ClientData) NULL);
  325.         Tcl_CreateExitHandler(FileHandlerExitProc, (ClientData) NULL);
  326.     }
  327.  
  328.     /*
  329.      * Make sure the file isn't already registered.  Create a
  330.      * new record in the normal case where there's no existing
  331.      * record.
  332.      */
  333.  
  334.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  335.         filePtr = filePtr->nextPtr) {
  336.     if (filePtr->file == file) {
  337.         break;
  338.     }
  339.     }
  340.     if (filePtr == NULL) {
  341.     filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
  342.     filePtr->file = file;
  343.     filePtr->nextPtr = firstFileHandlerPtr;
  344.     firstFileHandlerPtr = filePtr;
  345.     }
  346.  
  347.     /*
  348.      * The remainder of the initialization below is done regardless
  349.      * of whether or not this is a new record or a modification of
  350.      * an old one.
  351.      */
  352.  
  353.     filePtr->mask = mask;
  354.     filePtr->readyMask = 0;
  355.     filePtr->proc = proc;
  356.     filePtr->clientData = clientData;
  357. }
  358.  
  359. /*
  360.  *--------------------------------------------------------------
  361.  *
  362.  * Tcl_DeleteFileHandler --
  363.  *
  364.  *    Cancel a previously-arranged callback arrangement for
  365.  *    a file.
  366.  *
  367.  * Results:
  368.  *    None.
  369.  *
  370.  * Side effects:
  371.  *    If a callback was previously registered on file, remove it.
  372.  *
  373.  *--------------------------------------------------------------
  374.  */
  375.  
  376. void
  377. Tcl_DeleteFileHandler(file)
  378.     Tcl_File file;        /* Stream id for which to remove
  379.                  * callback procedure. */
  380. {
  381.     FileHandler *filePtr, *prevPtr;
  382.  
  383.     /*
  384.      * Find the entry for the given file (and return if there
  385.      * isn't one).
  386.      */
  387.  
  388.     for (prevPtr = NULL, filePtr = firstFileHandlerPtr; ;
  389.         prevPtr = filePtr, filePtr = filePtr->nextPtr) {
  390.     if (filePtr == NULL) {
  391.         return;
  392.     }
  393.     if (filePtr->file == file) {
  394.         break;
  395.     }
  396.     }
  397.  
  398.     /*
  399.      * Clean up information in the callback record.
  400.      */
  401.  
  402.     if (prevPtr == NULL) {
  403.     firstFileHandlerPtr = filePtr->nextPtr;
  404.     } else {
  405.     prevPtr->nextPtr = filePtr->nextPtr;
  406.     }
  407.     ckfree((char *) filePtr);
  408. }
  409.  
  410. /*
  411.  *----------------------------------------------------------------------
  412.  *
  413.  * FileHandlerExitProc --
  414.  *
  415.  *    Cleanup procedure to delete the file event source during exit
  416.  *    cleanup.
  417.  *
  418.  * Results:
  419.  *    None.
  420.  *
  421.  * Side effects:
  422.  *    Destroys the file event source.
  423.  *
  424.  *----------------------------------------------------------------------
  425.  */
  426.  
  427.     /* ARGSUSED */
  428. static void
  429. FileHandlerExitProc(clientData)
  430.     ClientData clientData;        /* Not used. */
  431. {
  432.     Tcl_DeleteEventSource(FileHandlerSetupProc, FileHandlerCheckProc,
  433.             (ClientData) NULL);
  434. }
  435.  
  436. /*
  437.  *----------------------------------------------------------------------
  438.  *
  439.  * FileHandlerSetupProc --
  440.  *
  441.  *    This procedure is part of the "event source" for file handlers.
  442.  *    It is invoked by Tcl_DoOneEvent before it calls select (or
  443.  *    whatever it uses to wait).
  444.  *
  445.  * Results:
  446.  *    None.
  447.  *
  448.  * Side effects:
  449.  *    Tells the notifier which files should be waited for.
  450.  *
  451.  *----------------------------------------------------------------------
  452.  */
  453.  
  454. static void
  455. FileHandlerSetupProc(clientData, flags)
  456.     ClientData clientData;        /* Not used. */
  457.     int flags;                /* Flags passed to Tk_DoOneEvent:
  458.                      * if it doesn't include
  459.                      * TCL_FILE_EVENTS then we do
  460.                      * nothing. */
  461. {
  462.     FileHandler *filePtr;
  463.  
  464.     if (!(flags & TCL_FILE_EVENTS)) {
  465.     return;
  466.     }
  467.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  468.         filePtr = filePtr->nextPtr) {
  469.     if (filePtr->mask != 0) {
  470.         Tcl_WatchFile(filePtr->file, filePtr->mask);
  471.     }
  472.     }
  473. }
  474.  
  475. /*
  476.  *----------------------------------------------------------------------
  477.  *
  478.  * FileHandlerCheckProc --
  479.  *
  480.  *    This procedure is the second part of the "event source" for
  481.  *    file handlers.  It is invoked by Tcl_DoOneEvent after it calls
  482.  *    select (or whatever it uses to wait for events).
  483.  *
  484.  * Results:
  485.  *    None.
  486.  *
  487.  * Side effects:
  488.  *    Makes entries on the Tcl event queue for each file that is
  489.  *    now ready.
  490.  *
  491.  *----------------------------------------------------------------------
  492.  */
  493.  
  494. static void
  495. FileHandlerCheckProc(clientData, flags)
  496.     ClientData clientData;        /* Not used. */
  497.     int flags;                /* Flags passed to Tk_DoOneEvent:
  498.                      * if it doesn't include 
  499.                      * TCL_FILE_EVENTS then we do
  500.                      * nothing. */
  501. {
  502.     FileHandler *filePtr;
  503.     FileHandlerEvent *fileEvPtr;
  504.  
  505.     if (!(flags & TCL_FILE_EVENTS)) {
  506.     return;
  507.     }
  508.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  509.         filePtr = filePtr->nextPtr) {
  510.     if (filePtr->mask != 0) {
  511.         filePtr->readyMask = Tcl_FileReady(filePtr->file, filePtr->mask);
  512.         if (filePtr->readyMask != 0) {
  513.         fileEvPtr = (FileHandlerEvent *) ckalloc(
  514.             sizeof(FileHandlerEvent));
  515.         fileEvPtr->header.proc = FileHandlerEventProc;
  516.         fileEvPtr->file = filePtr->file;
  517.         Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
  518.         }
  519.     }
  520.     }
  521. }
  522.  
  523. /*
  524.  *----------------------------------------------------------------------
  525.  *
  526.  * FileHandlerEventProc --
  527.  *
  528.  *    This procedure is called by Tcl_DoOneEvent when a file event
  529.  *    reaches the front of the event queue.  This procedure is responsible
  530.  *    for actually handling the event by invoking the callback for the
  531.  *    file handler.
  532.  *
  533.  * Results:
  534.  *    Returns 1 if the event was handled, meaning it should be removed
  535.  *    from the queue.  Returns 0 if the event was not handled, meaning
  536.  *    it should stay on the queue.  The only time the event isn't
  537.  *    handled is if the TCL_FILE_EVENTS flag bit isn't set.
  538.  *
  539.  * Side effects:
  540.  *    Whatever the file handler's callback procedure does
  541.  *
  542.  *----------------------------------------------------------------------
  543.  */
  544.  
  545. static int
  546. FileHandlerEventProc(evPtr, flags)
  547.     Tcl_Event *evPtr;        /* Event to service. */
  548.     int flags;            /* Flags that indicate what events to
  549.                  * handle, such as TCL_FILE_EVENTS. */
  550. {
  551.     FileHandler *filePtr;
  552.     FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
  553.     int mask;
  554.  
  555.     if (!(flags & TCL_FILE_EVENTS)) {
  556.     return 0;
  557.     }
  558.  
  559.     /*
  560.      * Search through the file handlers to find the one whose handle matches
  561.      * the event.  We do this rather than keeping a pointer to the file
  562.      * handler directly in the event, so that the handler can be deleted
  563.      * while the event is queued without leaving a dangling pointer.
  564.      */
  565.  
  566.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  567.         filePtr = filePtr->nextPtr) {
  568.     if (filePtr->file != fileEvPtr->file) {
  569.         continue;
  570.     }
  571.  
  572.     /*
  573.      * The code is tricky for two reasons:
  574.      * 1. The file handler's desired events could have changed
  575.      *    since the time when the event was queued, so AND the
  576.      *    ready mask with the desired mask.
  577.      * 2. The file could have been closed and re-opened since
  578.      *    the time when the event was queued.  This is why the
  579.      *    ready mask is stored in the file handler rather than
  580.      *    the queued event:  it will be zeroed when a new
  581.      *    file handler is created for the newly opened file.
  582.      */
  583.  
  584.     mask = filePtr->readyMask & filePtr->mask;
  585.     filePtr->readyMask = 0;
  586.     if (mask != 0) {
  587.         (*filePtr->proc)(filePtr->clientData, mask);
  588.     }
  589.     break;
  590.     }
  591.     return 1;
  592. }
  593.  
  594. /*
  595.  *--------------------------------------------------------------
  596.  *
  597.  * Tcl_CreateTimerHandler --
  598.  *
  599.  *    Arrange for a given procedure to be invoked at a particular
  600.  *    time in the future.
  601.  *
  602.  * Results:
  603.  *    The return value is a token for the timer event, which
  604.  *    may be used to delete the event before it fires.
  605.  *
  606.  * Side effects:
  607.  *    When milliseconds have elapsed, proc will be invoked
  608.  *    exactly once.
  609.  *
  610.  *--------------------------------------------------------------
  611.  */
  612.  
  613. Tcl_TimerToken
  614. Tcl_CreateTimerHandler(milliseconds, proc, clientData)
  615.     int milliseconds;        /* How many milliseconds to wait
  616.                  * before invoking proc. */
  617.     Tcl_TimerProc *proc;    /* Procedure to invoke. */
  618.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  619. {
  620.     register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
  621.     static int id = 0;
  622.  
  623.     if (!timerEventSourceCreated) {
  624.     timerEventSourceCreated = 1;
  625.     Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
  626.         (ClientData) NULL);
  627.         Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL);
  628.     }
  629.  
  630.     timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
  631.  
  632.     /*
  633.      * Compute when the event should fire.
  634.      */
  635.  
  636.     TclGetTime(&timerHandlerPtr->time);
  637.     timerHandlerPtr->time.sec += milliseconds/1000;
  638.     timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
  639.     if (timerHandlerPtr->time.usec >= 1000000) {
  640.     timerHandlerPtr->time.usec -= 1000000;
  641.     timerHandlerPtr->time.sec += 1;
  642.     }
  643.     
  644.     /*
  645.      * Fill in other fields for the event.
  646.      */
  647.  
  648.     timerHandlerPtr->proc = proc;
  649.     timerHandlerPtr->clientData = clientData;
  650.     id++;
  651.     timerHandlerPtr->token = (Tcl_TimerToken) id;
  652.  
  653.     /*
  654.      * Add the event to the queue in the correct position
  655.      * (ordered by event firing time).
  656.      */
  657.  
  658.     for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
  659.         prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
  660.     if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
  661.         || ((tPtr2->time.sec == timerHandlerPtr->time.sec)
  662.         && (tPtr2->time.usec > timerHandlerPtr->time.usec))) {
  663.         break;
  664.     }
  665.     }
  666.     timerHandlerPtr->nextPtr = tPtr2;
  667.     if (prevPtr == NULL) {
  668.     firstTimerHandlerPtr = timerHandlerPtr;
  669.     } else {
  670.     prevPtr->nextPtr = timerHandlerPtr;
  671.     }
  672.     return timerHandlerPtr->token;
  673. }
  674.  
  675. /*
  676.  *--------------------------------------------------------------
  677.  *
  678.  * Tcl_DeleteTimerHandler --
  679.  *
  680.  *    Delete a previously-registered timer handler.
  681.  *
  682.  * Results:
  683.  *    None.
  684.  *
  685.  * Side effects:
  686.  *    Destroy the timer callback identified by TimerToken,
  687.  *    so that its associated procedure will not be called.
  688.  *    If the callback has already fired, or if the given
  689.  *    token doesn't exist, then nothing happens.
  690.  *
  691.  *--------------------------------------------------------------
  692.  */
  693.  
  694. void
  695. Tcl_DeleteTimerHandler(token)
  696.     Tcl_TimerToken token;    /* Result previously returned by
  697.                  * Tcl_DeleteTimerHandler. */
  698. {
  699.     register TimerHandler *timerHandlerPtr, *prevPtr;
  700.  
  701.     for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL;
  702.         timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
  703.         timerHandlerPtr = timerHandlerPtr->nextPtr) {
  704.     if (timerHandlerPtr->token != token) {
  705.         continue;
  706.     }
  707.     if (prevPtr == NULL) {
  708.         firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
  709.     } else {
  710.         prevPtr->nextPtr = timerHandlerPtr->nextPtr;
  711.     }
  712.     ckfree((char *) timerHandlerPtr);
  713.     return;
  714.     }
  715. }
  716.  
  717. /*
  718.  *--------------------------------------------------------------
  719.  *
  720.  * Tcl_CreateModalTimeout --
  721.  *
  722.  *    Arrange for a given procedure to be invoked at a particular
  723.  *    time in the future, independently of all other timer events.
  724.  *
  725.  * Results:
  726.  *    None.
  727.  *
  728.  * Side effects:
  729.  *    When milliseconds have elapsed, proc will be invoked
  730.  *    exactly once.
  731.  *
  732.  *--------------------------------------------------------------
  733.  */
  734.  
  735. void
  736. Tcl_CreateModalTimeout(milliseconds, proc, clientData)
  737.     int milliseconds;        /* How many milliseconds to wait
  738.                  * before invoking proc. */
  739.     Tcl_TimerProc *proc;    /* Procedure to invoke. */
  740.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  741. {
  742.     TimerHandler *timerHandlerPtr;
  743.  
  744.     if (!timerEventSourceCreated) {
  745.     timerEventSourceCreated = 1;
  746.     Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
  747.         (ClientData) NULL);
  748.         Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL);
  749.     }
  750.  
  751.     timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
  752.  
  753.     /*
  754.      * Compute when the timeout should fire and fill in the other fields
  755.      * of the handler.
  756.      */
  757.  
  758.     TclGetTime(&timerHandlerPtr->time);
  759.     timerHandlerPtr->time.sec += milliseconds/1000;
  760.     timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
  761.     if (timerHandlerPtr->time.usec >= 1000000) {
  762.     timerHandlerPtr->time.usec -= 1000000;
  763.     timerHandlerPtr->time.sec += 1;
  764.     }
  765.     timerHandlerPtr->proc = proc;
  766.     timerHandlerPtr->clientData = clientData;
  767.  
  768.     /*
  769.      * Push the handler on the top of the modal stack.
  770.      */
  771.  
  772.     timerHandlerPtr->nextPtr = firstModalHandlerPtr;
  773.     firstModalHandlerPtr = timerHandlerPtr;
  774. }
  775.  
  776. /*
  777.  *--------------------------------------------------------------
  778.  *
  779.  * Tcl_DeleteModalTimeout --
  780.  *
  781.  *    Remove the topmost modal timer handler from the stack of
  782.  *    modal  handlers.
  783.  *
  784.  * Results:
  785.  *    None.
  786.  *
  787.  * Side effects:
  788.  *    Destroys the topmost modal timeout handler, which must
  789.  *    match proc and clientData.
  790.  *
  791.  *--------------------------------------------------------------
  792.  */
  793.  
  794. void
  795. Tcl_DeleteModalTimeout(proc, clientData)
  796.     Tcl_TimerProc *proc;    /* Callback procedure for the timeout. */
  797.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  798. {
  799.     TimerHandler *timerHandlerPtr;
  800.  
  801.     timerHandlerPtr = firstModalHandlerPtr;
  802.     firstModalHandlerPtr = timerHandlerPtr->nextPtr;
  803.     if ((timerHandlerPtr->proc != proc)
  804.         || (timerHandlerPtr->clientData != clientData)) {
  805.     panic("Tcl_DeleteModalTimeout found timeout stack corrupted");
  806.     }
  807.     ckfree((char *) timerHandlerPtr);
  808. }
  809.  
  810. /*
  811.  *----------------------------------------------------------------------
  812.  *
  813.  * TimerHandlerSetupProc --
  814.  *
  815.  *    This procedure is part of the "event source" for timers.
  816.  *    It is invoked by Tcl_DoOneEvent before it calls select (or
  817.  *    whatever it uses to wait).
  818.  *
  819.  * Results:
  820.  *    None.
  821.  *
  822.  * Side effects:
  823.  *    Tells the notifier how long to sleep if it decides to block.
  824.  *
  825.  *----------------------------------------------------------------------
  826.  */
  827.  
  828. static void
  829. TimerHandlerSetupProc(clientData, flags)
  830.     ClientData clientData;        /* Not used. */
  831.     int flags;                /* Flags passed to Tk_DoOneEvent:
  832.                      * if it doesn't include
  833.                      * TCL_TIMER_EVENTS then we only
  834.                      * consider modal timers. */
  835. {
  836.     TimerHandler *timerHandlerPtr, *tPtr2;
  837.     Tcl_Time blockTime;
  838.  
  839.     /*
  840.      * Find the timer handler (regular or modal) that fires first.
  841.      */
  842.  
  843.     timerHandlerPtr = firstTimerHandlerPtr;
  844.     if (!(flags & TCL_TIMER_EVENTS)) {
  845.     timerHandlerPtr = NULL;
  846.     }
  847.     if (timerHandlerPtr != NULL) {
  848.     tPtr2 = firstModalHandlerPtr;
  849.     if (tPtr2 != NULL) {
  850.         if ((timerHandlerPtr->time.sec > tPtr2->time.sec)
  851.             || ((timerHandlerPtr->time.sec == tPtr2->time.sec)
  852.             && (timerHandlerPtr->time.usec > tPtr2->time.usec))) {
  853.         timerHandlerPtr = tPtr2;
  854.         }
  855.     }
  856.     } else {
  857.     timerHandlerPtr = firstModalHandlerPtr;
  858.     }
  859.     if (timerHandlerPtr == NULL) {
  860.     return;
  861.     }
  862.  
  863.     TclGetTime(&blockTime);
  864.     blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec;
  865.     blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec;
  866.     if (blockTime.usec < 0) {
  867.     blockTime.sec -= 1;
  868.     blockTime.usec += 1000000;
  869.     }
  870.     if (blockTime.sec < 0) {
  871.     blockTime.sec = 0;
  872.     blockTime.usec = 0;
  873.     }
  874.     Tcl_SetMaxBlockTime(&blockTime);
  875. }
  876.  
  877. /*
  878.  *----------------------------------------------------------------------
  879.  *
  880.  * TimerHandlerCheckProc --
  881.  *
  882.  *    This procedure is the second part of the "event source" for
  883.  *    file handlers.  It is invoked by Tcl_DoOneEvent after it calls
  884.  *    select (or whatever it uses to wait for events).
  885.  *
  886.  * Results:
  887.  *    None.
  888.  *
  889.  * Side effects:
  890.  *    Makes entries on the Tcl event queue for each file that is
  891.  *    now ready.
  892.  *
  893.  *----------------------------------------------------------------------
  894.  */
  895.  
  896. static void
  897. TimerHandlerCheckProc(clientData, flags)
  898.     ClientData clientData;        /* Not used. */
  899.     int flags;                /* Flags passed to Tk_DoOneEvent:
  900.                      * if it doesn't include 
  901.                      * TCL_TIMER_EVENTS then we only
  902.                      * consider modal timeouts. */
  903. {
  904.     TimerHandler *timerHandlerPtr;
  905.     TimerEvent *timerEvPtr;
  906.     int triggered, gotTime;
  907.     Tcl_Time curTime;
  908.  
  909.     triggered = 0;
  910.     gotTime = 0;
  911.     timerHandlerPtr = firstTimerHandlerPtr;
  912.     if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) {
  913.     TclGetTime(&curTime);
  914.     gotTime = 1;
  915.     if ((timerHandlerPtr->time.sec < curTime.sec)
  916.         || ((timerHandlerPtr->time.sec == curTime.sec)
  917.         && (timerHandlerPtr->time.usec <= curTime.usec))) {
  918.         triggered = 1;
  919.     }
  920.     }
  921.     timerHandlerPtr = firstModalHandlerPtr;
  922.     if (timerHandlerPtr != NULL) {
  923.     if (!gotTime) {
  924.         TclGetTime(&curTime);
  925.     }
  926.     if ((timerHandlerPtr->time.sec < curTime.sec)
  927.         || ((timerHandlerPtr->time.sec == curTime.sec)
  928.         && (timerHandlerPtr->time.usec <= curTime.usec))) {
  929.         triggered = 1;
  930.     }
  931.     }
  932.     if (triggered) {
  933.     timerEvPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent));
  934.     timerEvPtr->header.proc = TimerHandlerEventProc;
  935.     timerEvPtr->time.sec = curTime.sec;
  936.     timerEvPtr->time.usec = curTime.usec;
  937.     Tcl_QueueEvent((Tcl_Event *) timerEvPtr, TCL_QUEUE_TAIL);
  938.     }
  939. }
  940.  
  941. /*
  942.  *----------------------------------------------------------------------
  943.  *
  944.  * TimerHandlerExitProc --
  945.  *
  946.  *    Callback invoked during exit cleanup to destroy the timer event
  947.  *    source.
  948.  *
  949.  * Results:
  950.  *    None.
  951.  *
  952.  * Side effects:
  953.  *    Destroys the timer event source.
  954.  *
  955.  *----------------------------------------------------------------------
  956.  */
  957.  
  958.     /* ARGSUSED */
  959. static void
  960. TimerHandlerExitProc(clientData)
  961.     ClientData clientData;        /* Not used. */
  962. {
  963.     Tcl_DeleteEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
  964.             (ClientData) NULL);
  965. }
  966.  
  967. /*
  968.  *----------------------------------------------------------------------
  969.  *
  970.  * TimerHandlerEventProc --
  971.  *
  972.  *    This procedure is called by Tcl_DoOneEvent when a timer event
  973.  *    reaches the front of the event queue.  This procedure handles
  974.  *    the event by invoking the callbacks for all timers that are
  975.  *    ready.
  976.  *
  977.  * Results:
  978.  *    Returns 1 if the event was handled, meaning it should be removed
  979.  *    from the queue.  Returns 0 if the event was not handled, meaning
  980.  *    it should stay on the queue.  The only time the event isn't
  981.  *    handled is if the TCL_TIMER_EVENTS flag bit isn't set.
  982.  *
  983.  * Side effects:
  984.  *    Whatever the timer handler callback procedures do.
  985.  *
  986.  *----------------------------------------------------------------------
  987.  */
  988.  
  989. static int
  990. TimerHandlerEventProc(evPtr, flags)
  991.     Tcl_Event *evPtr;        /* Event to service. */
  992.     int flags;            /* Flags that indicate what events to
  993.                  * handle, such as TCL_FILE_EVENTS. */
  994. {
  995.     TimerHandler *timerHandlerPtr;
  996.     TimerEvent *timerEvPtr = (TimerEvent *) evPtr;
  997.  
  998.     /*
  999.      * Invoke the current modal timeout first, if there is one and
  1000.      * it has triggered.
  1001.      */
  1002.  
  1003.     timerHandlerPtr = firstModalHandlerPtr;
  1004.     if (firstModalHandlerPtr != NULL) {
  1005.     if ((timerHandlerPtr->time.sec < timerEvPtr->time.sec)
  1006.         || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec)
  1007.         && (timerHandlerPtr->time.usec <= timerEvPtr->time.usec))) {
  1008.         (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
  1009.     }
  1010.     }
  1011.  
  1012.     /*
  1013.      * Invoke any normal timers that have fired.
  1014.      */
  1015.  
  1016.     if (!(flags & TCL_TIMER_EVENTS)) {
  1017.     return 1;
  1018.     }
  1019.  
  1020.     while (1) {
  1021.     timerHandlerPtr = firstTimerHandlerPtr;
  1022.     if (timerHandlerPtr == NULL) {
  1023.         break;
  1024.     }
  1025.     if ((timerHandlerPtr->time.sec > timerEvPtr->time.sec)
  1026.         || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec)
  1027.         && (timerHandlerPtr->time.usec >= timerEvPtr->time.usec))) {
  1028.         break;
  1029.     }
  1030.  
  1031.     /*
  1032.      * Remove the handler from the queue before invoking it,
  1033.      * to avoid potential reentrancy problems.
  1034.      */
  1035.  
  1036.     firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
  1037.     (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
  1038.     ckfree((char *) timerHandlerPtr);
  1039.     }
  1040.     return 1;
  1041. }
  1042.  
  1043. /*
  1044.  *--------------------------------------------------------------
  1045.  *
  1046.  * Tcl_DoWhenIdle --
  1047.  *
  1048.  *    Arrange for proc to be invoked the next time the system is
  1049.  *    idle (i.e., just before the next time that Tcl_DoOneEvent
  1050.  *    would have to wait for something to happen).
  1051.  *
  1052.  * Results:
  1053.  *    None.
  1054.  *
  1055.  * Side effects:
  1056.  *    Proc will eventually be called, with clientData as argument.
  1057.  *    See the manual entry for details.
  1058.  *
  1059.  *--------------------------------------------------------------
  1060.  */
  1061.  
  1062. void
  1063. Tcl_DoWhenIdle(proc, clientData)
  1064.     Tcl_IdleProc *proc;        /* Procedure to invoke. */
  1065.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1066. {
  1067.     register IdleHandler *idlePtr;
  1068.  
  1069.     idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
  1070.     idlePtr->proc = proc;
  1071.     idlePtr->clientData = clientData;
  1072.     idlePtr->generation = idleGeneration;
  1073.     idlePtr->nextPtr = NULL;
  1074.     if (lastIdlePtr == NULL) {
  1075.     idleList = idlePtr;
  1076.     } else {
  1077.     lastIdlePtr->nextPtr = idlePtr;
  1078.     }
  1079.     lastIdlePtr = idlePtr;
  1080. }
  1081.  
  1082. /*
  1083.  *----------------------------------------------------------------------
  1084.  *
  1085.  * Tcl_CancelIdleCall --
  1086.  *
  1087.  *    If there are any when-idle calls requested to a given procedure
  1088.  *    with given clientData, cancel all of them.
  1089.  *
  1090.  * Results:
  1091.  *    None.
  1092.  *
  1093.  * Side effects:
  1094.  *    If the proc/clientData combination were on the when-idle list,
  1095.  *    they are removed so that they will never be called.
  1096.  *
  1097.  *----------------------------------------------------------------------
  1098.  */
  1099.  
  1100. void
  1101. Tcl_CancelIdleCall(proc, clientData)
  1102.     Tcl_IdleProc *proc;        /* Procedure that was previously registered. */
  1103.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1104. {
  1105.     register IdleHandler *idlePtr, *prevPtr;
  1106.     IdleHandler *nextPtr;
  1107.  
  1108.     for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL;
  1109.         prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
  1110.     while ((idlePtr->proc == proc)
  1111.         && (idlePtr->clientData == clientData)) {
  1112.         nextPtr = idlePtr->nextPtr;
  1113.         ckfree((char *) idlePtr);
  1114.         idlePtr = nextPtr;
  1115.         if (prevPtr == NULL) {
  1116.         idleList = idlePtr;
  1117.         } else {
  1118.         prevPtr->nextPtr = idlePtr;
  1119.         }
  1120.         if (idlePtr == NULL) {
  1121.         lastIdlePtr = prevPtr;
  1122.         return;
  1123.         }
  1124.     }
  1125.     }
  1126. }
  1127.  
  1128. /*
  1129.  *----------------------------------------------------------------------
  1130.  *
  1131.  * TclIdlePending --
  1132.  *
  1133.  *    This function is called by the notifier subsystem to determine
  1134.  *    whether there are any idle handlers currently scheduled.
  1135.  *
  1136.  * Results:
  1137.  *    Returns 0 if the idle list is empty, otherwise it returns 1.
  1138.  *
  1139.  * Side effects:
  1140.  *    None.
  1141.  *
  1142.  *----------------------------------------------------------------------
  1143.  */
  1144.  
  1145. int
  1146. TclIdlePending()
  1147. {
  1148.     return (idleList == NULL) ? 0 : 1;
  1149. }
  1150.  
  1151. /*
  1152.  *----------------------------------------------------------------------
  1153.  *
  1154.  * TclServiceIdle --
  1155.  *
  1156.  *    This procedure is invoked by the notifier when it becomes idle.
  1157.  *
  1158.  * Results:
  1159.  *    The return value is 1 if the procedure actually found an idle
  1160.  *    handler to invoke.  If no handler was found then 0 is returned.
  1161.  *
  1162.  * Side effects:
  1163.  *    Invokes all pending idle handlers.
  1164.  *
  1165.  *----------------------------------------------------------------------
  1166.  */
  1167.  
  1168. int
  1169. TclServiceIdle()
  1170. {
  1171.     IdleHandler *idlePtr;
  1172.     int oldGeneration;
  1173.     int foundIdle;
  1174.  
  1175.     if (idleList == NULL) {
  1176.     return 0;
  1177.     }
  1178.     
  1179.     foundIdle = 0;
  1180.     oldGeneration = idleGeneration;
  1181.     idleGeneration++;
  1182.  
  1183.     /*
  1184.      * The code below is trickier than it may look, for the following
  1185.      * reasons:
  1186.      *
  1187.      * 1. New handlers can get added to the list while the current
  1188.      *    one is being processed.  If new ones get added, we don't
  1189.      *    want to process them during this pass through the list (want
  1190.      *    to check for other work to do first).  This is implemented
  1191.      *    using the generation number in the handler:  new handlers
  1192.      *    will have a different generation than any of the ones currently
  1193.      *    on the list.
  1194.      * 2. The handler can call Tcl_DoOneEvent, so we have to remove
  1195.      *    the handler from the list before calling it. Otherwise an
  1196.      *    infinite loop could result.
  1197.      * 3. Tcl_CancelIdleCall can be called to remove an element from
  1198.      *    the list while a handler is executing, so the list could
  1199.      *    change structure during the call.
  1200.      */
  1201.  
  1202.     for (idlePtr = idleList;
  1203.         ((idlePtr != NULL)
  1204.             && ((oldGeneration - idlePtr->generation) >= 0));
  1205.         idlePtr = idleList) {
  1206.     idleList = idlePtr->nextPtr;
  1207.     if (idleList == NULL) {
  1208.         lastIdlePtr = NULL;
  1209.     }
  1210.     foundIdle = 1;
  1211.     (*idlePtr->proc)(idlePtr->clientData);
  1212.     ckfree((char *) idlePtr);
  1213.     }
  1214.  
  1215.     return foundIdle;
  1216. }
  1217.  
  1218. /*
  1219.  *----------------------------------------------------------------------
  1220.  *
  1221.  * Tcl_BackgroundError --
  1222.  *
  1223.  *    This procedure is invoked to handle errors that occur in Tcl
  1224.  *    commands that are invoked in "background" (e.g. from event or
  1225.  *    timer bindings).
  1226.  *
  1227.  * Results:
  1228.  *    None.
  1229.  *
  1230.  * Side effects:
  1231.  *    The command "bgerror" is invoked later as an idle handler to
  1232.  *    process the error, passing it the error message.  If that fails,
  1233.  *    then an error message is output on stderr.
  1234.  *
  1235.  *----------------------------------------------------------------------
  1236.  */
  1237.  
  1238. void
  1239. Tcl_BackgroundError(interp)
  1240.     Tcl_Interp *interp;        /* Interpreter in which an error has
  1241.                  * occurred. */
  1242. {
  1243.     BgError *errPtr;
  1244.     char *varValue;
  1245.     ErrAssocData *assocPtr;
  1246.  
  1247.     /*
  1248.      * The Tcl_AddErrorInfo call below (with an empty string) ensures that
  1249.      * errorInfo gets properly set.  It's needed in cases where the error
  1250.      * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
  1251.      * in these cases errorInfo still won't have been set when this
  1252.      * procedure is called.
  1253.      */
  1254.  
  1255.     Tcl_AddErrorInfo(interp, "");
  1256.     errPtr = (BgError *) ckalloc(sizeof(BgError));
  1257.     errPtr->interp = interp;
  1258.     errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result)
  1259.         + 1));
  1260.     strcpy(errPtr->errorMsg, interp->result);
  1261.     varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
  1262.     if (varValue == NULL) {
  1263.     varValue = errPtr->errorMsg;
  1264.     }
  1265.     errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
  1266.     strcpy(errPtr->errorInfo, varValue);
  1267.     varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
  1268.     if (varValue == NULL) {
  1269.     varValue = "";
  1270.     }
  1271.     errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
  1272.     strcpy(errPtr->errorCode, varValue);
  1273.     errPtr->nextPtr = NULL;
  1274.  
  1275.     assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
  1276.         (Tcl_InterpDeleteProc **) NULL);
  1277.     if (assocPtr == NULL) {
  1278.  
  1279.     /*
  1280.      * This is the first time a background error has occurred in
  1281.      * this interpreter.  Create associated data to keep track of
  1282.      * pending error reports.
  1283.      */
  1284.  
  1285.     assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
  1286.     assocPtr->firstBgPtr = NULL;
  1287.     assocPtr->lastBgPtr = NULL;
  1288.     Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
  1289.         (ClientData) assocPtr);
  1290.     }
  1291.     if (assocPtr->firstBgPtr == NULL) {
  1292.     assocPtr->firstBgPtr = errPtr;
  1293.     Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
  1294.     } else {
  1295.     assocPtr->lastBgPtr->nextPtr = errPtr;
  1296.     }
  1297.     assocPtr->lastBgPtr = errPtr;
  1298.     Tcl_ResetResult(interp);
  1299. }
  1300.  
  1301. /*
  1302.  *----------------------------------------------------------------------
  1303.  *
  1304.  * HandleBgErrors --
  1305.  *
  1306.  *    This procedure is invoked as an idle handler to process all of
  1307.  *    the accumulated background errors.
  1308.  *
  1309.  * Results:
  1310.  *    None.
  1311.  *
  1312.  * Side effects:
  1313.  *    Depends on what actions "bgerror" takes for the errors.
  1314.  *
  1315.  *----------------------------------------------------------------------
  1316.  */
  1317.  
  1318. static void
  1319. HandleBgErrors(clientData)
  1320.     ClientData clientData;    /* Pointer to ErrAssocData structure. */
  1321. {
  1322.     Tcl_Interp *interp;
  1323.     char *command;
  1324.     char *argv[2];
  1325.     int code;
  1326.     BgError *errPtr;
  1327.     ErrAssocData *assocPtr = (ErrAssocData *) clientData;
  1328.     Tcl_Channel errChannel;
  1329.  
  1330.     while (assocPtr->firstBgPtr != NULL) {
  1331.     interp = assocPtr->firstBgPtr->interp;
  1332.     if (interp == NULL) {
  1333.         goto doneWithReport;
  1334.     }
  1335.  
  1336.     /*
  1337.      * Restore important state variables to what they were at
  1338.      * the time the error occurred.
  1339.      */
  1340.  
  1341.     Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
  1342.         TCL_GLOBAL_ONLY);
  1343.     Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
  1344.         TCL_GLOBAL_ONLY);
  1345.  
  1346.     /*
  1347.      * Create and invoke the bgerror command.
  1348.      */
  1349.  
  1350.     argv[0] = "bgerror";
  1351.     argv[1] = assocPtr->firstBgPtr->errorMsg;
  1352.     command = Tcl_Merge(2, argv);
  1353.     Tcl_AllowExceptions(interp);
  1354.         Tcl_Preserve((ClientData) interp);
  1355.     code = Tcl_GlobalEval(interp, command);
  1356.     ckfree(command);
  1357.     if (code == TCL_ERROR) {
  1358.  
  1359.             /*
  1360.              * We have to get the error output channel at the latest possible
  1361.              * time, because the eval (above) might have changed the channel.
  1362.              */
  1363.             
  1364.             errChannel = Tcl_GetStdChannel(TCL_STDERR);
  1365.             if (errChannel != (Tcl_Channel) NULL) {
  1366.                 if (strcmp(interp->result,
  1367.            "\"bgerror\" is an invalid command name or ambiguous abbreviation")
  1368.                         == 0) {
  1369.                     Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
  1370.                     Tcl_Write(errChannel, "\n", -1);
  1371.                 } else {
  1372.                     Tcl_Write(errChannel,
  1373.                             "bgerror failed to handle background error.\n",
  1374.                             -1);
  1375.                     Tcl_Write(errChannel, "    Original error: ", -1);
  1376.                     Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg,
  1377.                             -1);
  1378.                     Tcl_Write(errChannel, "\n", -1);
  1379.                     Tcl_Write(errChannel, "    Error in bgerror: ", -1);
  1380.                     Tcl_Write(errChannel, interp->result, -1);
  1381.                     Tcl_Write(errChannel, "\n", -1);
  1382.                 }
  1383.                 Tcl_Flush(errChannel);
  1384.             }
  1385.     } else if (code == TCL_BREAK) {
  1386.  
  1387.         /*
  1388.          * Break means cancel any remaining error reports for this
  1389.          * interpreter.
  1390.          */
  1391.  
  1392.         for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
  1393.             errPtr = errPtr->nextPtr) {
  1394.         if (errPtr->interp == interp) {
  1395.             errPtr->interp = NULL;
  1396.         }
  1397.         }
  1398.     }
  1399.  
  1400.         Tcl_Release((ClientData) interp);
  1401.  
  1402.     /*
  1403.      * Discard the command and the information about the error report.
  1404.      */
  1405.  
  1406.     doneWithReport:
  1407.     ckfree(assocPtr->firstBgPtr->errorMsg);
  1408.     ckfree(assocPtr->firstBgPtr->errorInfo);
  1409.     ckfree(assocPtr->firstBgPtr->errorCode);
  1410.     errPtr = assocPtr->firstBgPtr->nextPtr;
  1411.     ckfree((char *) assocPtr->firstBgPtr);
  1412.     assocPtr->firstBgPtr = errPtr;
  1413.     }
  1414.     assocPtr->lastBgPtr = NULL;
  1415. }
  1416.  
  1417. /*
  1418.  *----------------------------------------------------------------------
  1419.  *
  1420.  * BgErrorDeleteProc --
  1421.  *
  1422.  *    This procedure is associated with the "tclBgError" assoc data
  1423.  *    for an interpreter;  it is invoked when the interpreter is
  1424.  *    deleted in order to free the information assoicated with any
  1425.  *    pending error reports.
  1426.  *
  1427.  * Results:
  1428.  *    None.
  1429.  *
  1430.  * Side effects:
  1431.  *    Background error information is freed: if there were any
  1432.  *    pending error reports, they are cancelled.
  1433.  *
  1434.  *----------------------------------------------------------------------
  1435.  */
  1436.  
  1437. static void
  1438. BgErrorDeleteProc(clientData, interp)
  1439.     ClientData clientData;    /* Pointer to ErrAssocData structure. */
  1440.     Tcl_Interp *interp;        /* Interpreter being deleted. */
  1441. {
  1442.     ErrAssocData *assocPtr = (ErrAssocData *) clientData;
  1443.     BgError *errPtr;
  1444.  
  1445.     while (assocPtr->firstBgPtr != NULL) {
  1446.     errPtr = assocPtr->firstBgPtr;
  1447.     assocPtr->firstBgPtr = errPtr->nextPtr;
  1448.     ckfree(errPtr->errorMsg);
  1449.     ckfree(errPtr->errorInfo);
  1450.     ckfree(errPtr->errorCode);
  1451.     ckfree((char *) errPtr);
  1452.     }
  1453.     ckfree((char *) assocPtr);
  1454.     Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
  1455. }
  1456.  
  1457. /*
  1458.  *----------------------------------------------------------------------
  1459.  *
  1460.  * Tcl_CreateExitHandler --
  1461.  *
  1462.  *    Arrange for a given procedure to be invoked just before the
  1463.  *    application exits.
  1464.  *
  1465.  * Results:
  1466.  *    None.
  1467.  *
  1468.  * Side effects:
  1469.  *    Proc will be invoked with clientData as argument when the
  1470.  *    application exits.
  1471.  *
  1472.  *----------------------------------------------------------------------
  1473.  */
  1474.  
  1475. void
  1476. Tcl_CreateExitHandler(proc, clientData)
  1477.     Tcl_ExitProc *proc;        /* Procedure to invoke. */
  1478.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1479. {
  1480.     ExitHandler *exitPtr;
  1481.  
  1482.     exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
  1483.     exitPtr->proc = proc;
  1484.     exitPtr->clientData = clientData;
  1485.     exitPtr->nextPtr = firstExitPtr;
  1486.     firstExitPtr = exitPtr;
  1487. }
  1488.  
  1489. /*
  1490.  *----------------------------------------------------------------------
  1491.  *
  1492.  * Tcl_DeleteExitHandler --
  1493.  *
  1494.  *    This procedure cancels an existing exit handler matching proc
  1495.  *    and clientData, if such a handler exits.
  1496.  *
  1497.  * Results:
  1498.  *    None.
  1499.  *
  1500.  * Side effects:
  1501.  *    If there is an exit handler corresponding to proc and clientData
  1502.  *    then it is cancelled;  if no such handler exists then nothing
  1503.  *    happens.
  1504.  *
  1505.  *----------------------------------------------------------------------
  1506.  */
  1507.  
  1508. void
  1509. Tcl_DeleteExitHandler(proc, clientData)
  1510.     Tcl_ExitProc *proc;        /* Procedure that was previously registered. */
  1511.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1512. {
  1513.     ExitHandler *exitPtr, *prevPtr;
  1514.  
  1515.     for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
  1516.         prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
  1517.     if ((exitPtr->proc == proc)
  1518.         && (exitPtr->clientData == clientData)) {
  1519.         if (prevPtr == NULL) {
  1520.         firstExitPtr = exitPtr->nextPtr;
  1521.         } else {
  1522.         prevPtr->nextPtr = exitPtr->nextPtr;
  1523.         }
  1524.         ckfree((char *) exitPtr);
  1525.         return;
  1526.     }
  1527.     }
  1528. }
  1529.  
  1530. /*
  1531.  *----------------------------------------------------------------------
  1532.  *
  1533.  * Tcl_Exit --
  1534.  *
  1535.  *    This procedure is called to terminate the application.
  1536.  *
  1537.  * Results:
  1538.  *    None.
  1539.  *
  1540.  * Side effects:
  1541.  *    All existing exit handlers are invoked, then the application
  1542.  *    ends.
  1543.  *
  1544.  *----------------------------------------------------------------------
  1545.  */
  1546.  
  1547. void
  1548. Tcl_Exit(status)
  1549.     int status;            /* Exit status for application;  typically
  1550.                  * 0 for normal return, 1 for error return. */
  1551. {
  1552.     ExitHandler *exitPtr;
  1553.  
  1554.     for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
  1555.     /*
  1556.      * Be careful to remove the handler from the list before invoking
  1557.      * its callback.  This protects us against double-freeing if the
  1558.      * callback should call Tcl_DeleteExitHandler on itself.
  1559.      */
  1560.  
  1561.     firstExitPtr = exitPtr->nextPtr;
  1562.     (*exitPtr->proc)(exitPtr->clientData);
  1563.     ckfree((char *) exitPtr);
  1564.     }
  1565. #ifdef TCL_MEM_DEBUG
  1566.     if (tclMemDumpFileName != NULL) {
  1567.     Tcl_DumpActiveMemory(tclMemDumpFileName);
  1568.     }
  1569. #endif
  1570.     
  1571.     TclPlatformExit(status);
  1572. }
  1573.  
  1574. /*
  1575.  *----------------------------------------------------------------------
  1576.  *
  1577.  * Tcl_AfterCmd --
  1578.  *
  1579.  *    This procedure is invoked to process the "after" Tcl command.
  1580.  *    See the user documentation for details on what it does.
  1581.  *
  1582.  * Results:
  1583.  *    A standard Tcl result.
  1584.  *
  1585.  * Side effects:
  1586.  *    See the user documentation.
  1587.  *
  1588.  *----------------------------------------------------------------------
  1589.  */
  1590.  
  1591.     /* ARGSUSED */
  1592. int
  1593. Tcl_AfterCmd(clientData, interp, argc, argv)
  1594.     ClientData clientData;    /* Points to the "tclAfter" assocData for
  1595.                  * this interpreter, or NULL if the assocData
  1596.                  * hasn't been created yet.*/
  1597.     Tcl_Interp *interp;        /* Current interpreter. */
  1598.     int argc;            /* Number of arguments. */
  1599.     char **argv;        /* Argument strings. */
  1600. {
  1601.     /*
  1602.      * The variable below is used to generate unique identifiers for
  1603.      * after commands.  This id can wrap around, which can potentially
  1604.      * cause problems.  However, there are not likely to be problems
  1605.      * in practice, because after commands can only be requested to
  1606.      * about a month in the future, and wrap-around is unlikely to
  1607.      * occur in less than about 1-10 years.  Thus it's unlikely that
  1608.      * any old ids will still be around when wrap-around occurs.
  1609.      */
  1610.  
  1611.     static int nextId = 1;
  1612.     int ms;
  1613.     AfterInfo *afterPtr;
  1614.     AfterAssocData *assocPtr = (AfterAssocData *) clientData;
  1615.     Tcl_CmdInfo cmdInfo;
  1616.     size_t length;
  1617.  
  1618.     if (argc < 2) {
  1619.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1620.         argv[0], " option ?arg arg ...?\"", (char *) NULL);
  1621.     return TCL_ERROR;
  1622.     }
  1623.  
  1624.     /*
  1625.      * Create the "after" information associated for this interpreter,
  1626.      * if it doesn't already exist.  Associate it with the command too,
  1627.      * so that it will be passed in as the ClientData argument in the
  1628.      * future.
  1629.      */
  1630.  
  1631.     if (assocPtr == NULL) {
  1632.     assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
  1633.     assocPtr->interp = interp;
  1634.     assocPtr->firstAfterPtr = NULL;
  1635.     Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
  1636.         (ClientData) assocPtr);
  1637.     cmdInfo.proc = Tcl_AfterCmd;
  1638.     cmdInfo.clientData = (ClientData) assocPtr;
  1639.     cmdInfo.deleteProc = NULL;
  1640.     cmdInfo.deleteData = (ClientData) assocPtr;
  1641.     Tcl_SetCommandInfo(interp, argv[0], &cmdInfo);
  1642.     }
  1643.  
  1644.     /*
  1645.      * Parse the command.
  1646.      */
  1647.  
  1648.     length = strlen(argv[1]);
  1649.     if (isdigit(UCHAR(argv[1][0]))) {
  1650.     if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) {
  1651.         return TCL_ERROR;
  1652.     }
  1653.     if (ms < 0) {
  1654.         ms = 0;
  1655.     }
  1656.     if (argc == 2) {
  1657.         Tcl_Sleep(ms);
  1658.         return TCL_OK;
  1659.     }
  1660.     afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
  1661.     afterPtr->assocPtr = assocPtr;
  1662.     if (argc == 3) {
  1663.         afterPtr->command = (char *) ckalloc((unsigned)
  1664.             (strlen(argv[2]) + 1));
  1665.         strcpy(afterPtr->command, argv[2]);
  1666.     } else {
  1667.         afterPtr->command = Tcl_Concat(argc-2, argv+2);
  1668.     }
  1669.     afterPtr->id = nextId;
  1670.     nextId += 1;
  1671.     afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
  1672.         (ClientData) afterPtr);
  1673.     afterPtr->nextPtr = assocPtr->firstAfterPtr;
  1674.     assocPtr->firstAfterPtr = afterPtr;
  1675.     sprintf(interp->result, "after#%d", afterPtr->id);
  1676.     } else if (strncmp(argv[1], "cancel", length) == 0) {
  1677.     char *arg;
  1678.  
  1679.     if (argc < 3) {
  1680.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1681.             argv[0], " cancel id|command\"", (char *) NULL);
  1682.         return TCL_ERROR;
  1683.     }
  1684.     if (argc == 3) {
  1685.         arg = argv[2];
  1686.     } else {
  1687.         arg = Tcl_Concat(argc-2, argv+2);
  1688.     }
  1689.     for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
  1690.         afterPtr = afterPtr->nextPtr) {
  1691.         if (strcmp(afterPtr->command, arg) == 0) {
  1692.         break;
  1693.         }
  1694.     }
  1695.     if (afterPtr == NULL) {
  1696.         afterPtr = GetAfterEvent(assocPtr, arg);
  1697.     }
  1698.     if (arg != argv[2]) {
  1699.         ckfree(arg);
  1700.     }
  1701.     if (afterPtr != NULL) {
  1702.         if (afterPtr->token != NULL) {
  1703.         Tcl_DeleteTimerHandler(afterPtr->token);
  1704.         } else {
  1705.         Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
  1706.         }
  1707.         FreeAfterPtr(afterPtr);
  1708.     }
  1709.     } else if ((strncmp(argv[1], "idle", length) == 0)
  1710.          && (length >= 2)) {
  1711.     if (argc < 3) {
  1712.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1713.             argv[0], " idle script script ...\"", (char *) NULL);
  1714.         return TCL_ERROR;
  1715.     }
  1716.     afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
  1717.     afterPtr->assocPtr = assocPtr;
  1718.     if (argc == 3) {
  1719.         afterPtr->command = (char *) ckalloc((unsigned)
  1720.             (strlen(argv[2]) + 1));
  1721.         strcpy(afterPtr->command, argv[2]);
  1722.     } else {
  1723.         afterPtr->command = Tcl_Concat(argc-2, argv+2);
  1724.     }
  1725.     afterPtr->id = nextId;
  1726.     nextId += 1;
  1727.     afterPtr->token = NULL;
  1728.     afterPtr->nextPtr = assocPtr->firstAfterPtr;
  1729.     assocPtr->firstAfterPtr = afterPtr;
  1730.     Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
  1731.     sprintf(interp->result, "after#%d", afterPtr->id);
  1732.     } else if ((strncmp(argv[1], "info", length) == 0)
  1733.          && (length >= 2)) {
  1734.     if (argc == 2) {
  1735.         char buffer[30];
  1736.         
  1737.         for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
  1738.             afterPtr = afterPtr->nextPtr) {
  1739.         if (assocPtr->interp == interp) {
  1740.             sprintf(buffer, "after#%d", afterPtr->id);
  1741.             Tcl_AppendElement(interp, buffer);
  1742.         }
  1743.         }
  1744.         return TCL_OK;
  1745.     }
  1746.     if (argc != 3) {
  1747.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1748.             argv[0], " info ?id?\"", (char *) NULL);
  1749.         return TCL_ERROR;
  1750.     }
  1751.     afterPtr = GetAfterEvent(assocPtr, argv[2]);
  1752.     if (afterPtr == NULL) {
  1753.         Tcl_AppendResult(interp, "event \"", argv[2],
  1754.             "\" doesn't exist", (char *) NULL);
  1755.         return TCL_ERROR;
  1756.     }
  1757.     Tcl_AppendElement(interp, afterPtr->command);
  1758.     Tcl_AppendElement(interp,
  1759.         (afterPtr->token == NULL) ? "idle" : "timer");
  1760.     } else {
  1761.     Tcl_AppendResult(interp, "bad argument \"", argv[1],
  1762.         "\": must be cancel, idle, info, or a number",
  1763.         (char *) NULL);
  1764.     return TCL_ERROR;
  1765.     }
  1766.     return TCL_OK;
  1767. }
  1768.  
  1769. /*
  1770.  *----------------------------------------------------------------------
  1771.  *
  1772.  * GetAfterEvent --
  1773.  *
  1774.  *    This procedure parses an "after" id such as "after#4" and
  1775.  *    returns a pointer to the AfterInfo structure.
  1776.  *
  1777.  * Results:
  1778.  *    The return value is either a pointer to an AfterInfo structure,
  1779.  *    if one is found that corresponds to "string" and is for interp,
  1780.  *    or NULL if no corresponding after event can be found.
  1781.  *
  1782.  * Side effects:
  1783.  *    None.
  1784.  *
  1785.  *----------------------------------------------------------------------
  1786.  */
  1787.  
  1788. static AfterInfo *
  1789. GetAfterEvent(assocPtr, string)
  1790.     AfterAssocData *assocPtr;    /* Points to "after"-related information for
  1791.                  * this interpreter. */
  1792.     char *string;        /* Textual identifier for after event, such
  1793.                  * as "after#6". */
  1794. {
  1795.     AfterInfo *afterPtr;
  1796.     int id;
  1797.     char *end;
  1798.  
  1799.     if (strncmp(string, "after#", 6) != 0) {
  1800.     return NULL;
  1801.     }
  1802.     string += 6;
  1803.     id = strtoul(string, &end, 10);
  1804.     if ((end == string) || (*end != 0)) {
  1805.     return NULL;
  1806.     }
  1807.     for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
  1808.         afterPtr = afterPtr->nextPtr) {
  1809.     if (afterPtr->id == id) {
  1810.         return afterPtr;
  1811.     }
  1812.     }
  1813.     return NULL;
  1814. }
  1815.  
  1816. /*
  1817.  *----------------------------------------------------------------------
  1818.  *
  1819.  * AfterProc --
  1820.  *
  1821.  *    Timer callback to execute commands registered with the
  1822.  *    "after" command.
  1823.  *
  1824.  * Results:
  1825.  *    None.
  1826.  *
  1827.  * Side effects:
  1828.  *    Executes whatever command was specified.  If the command
  1829.  *    returns an error, then the command "bgerror" is invoked
  1830.  *    to process the error;  if bgerror fails then information
  1831.  *    about the error is output on stderr.
  1832.  *
  1833.  *----------------------------------------------------------------------
  1834.  */
  1835.  
  1836. static void
  1837. AfterProc(clientData)
  1838.     ClientData clientData;    /* Describes command to execute. */
  1839. {
  1840.     AfterInfo *afterPtr = (AfterInfo *) clientData;
  1841.     AfterAssocData *assocPtr = afterPtr->assocPtr;
  1842.     AfterInfo *prevPtr;
  1843.     int result;
  1844.     Tcl_Interp *interp;
  1845.  
  1846.     /*
  1847.      * First remove the callback from our list of callbacks;  otherwise
  1848.      * someone could delete the callback while it's being executed, which
  1849.      * could cause a core dump.
  1850.      */
  1851.  
  1852.     if (assocPtr->firstAfterPtr == afterPtr) {
  1853.     assocPtr->firstAfterPtr = afterPtr->nextPtr;
  1854.     } else {
  1855.     for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
  1856.         prevPtr = prevPtr->nextPtr) {
  1857.         /* Empty loop body. */
  1858.     }
  1859.     prevPtr->nextPtr = afterPtr->nextPtr;
  1860.     }
  1861.  
  1862.     /*
  1863.      * Execute the callback.
  1864.      */
  1865.  
  1866.     interp = assocPtr->interp;
  1867.     Tcl_Preserve((ClientData) interp);
  1868.     result = Tcl_GlobalEval(interp, afterPtr->command);
  1869.     if (result != TCL_OK) {
  1870.     Tcl_AddErrorInfo(interp, "\n    (\"after\" script)");
  1871.     Tcl_BackgroundError(interp);
  1872.     }
  1873.     Tcl_Release((ClientData) interp);
  1874.     
  1875.     /*
  1876.      * Free the memory for the callback.
  1877.      */
  1878.  
  1879.     ckfree(afterPtr->command);
  1880.     ckfree((char *) afterPtr);
  1881. }
  1882.  
  1883. /*
  1884.  *----------------------------------------------------------------------
  1885.  *
  1886.  * FreeAfterPtr --
  1887.  *
  1888.  *    This procedure removes an "after" command from the list of
  1889.  *    those that are pending and frees its resources.  This procedure
  1890.  *    does *not* cancel the timer handler;  if that's needed, the
  1891.  *    caller must do it.
  1892.  *
  1893.  * Results:
  1894.  *    None.
  1895.  *
  1896.  * Side effects:
  1897.  *    The memory associated with afterPtr is released.
  1898.  *
  1899.  *----------------------------------------------------------------------
  1900.  */
  1901.  
  1902. static void
  1903. FreeAfterPtr(afterPtr)
  1904.     AfterInfo *afterPtr;        /* Command to be deleted. */
  1905. {
  1906.     AfterInfo *prevPtr;
  1907.     AfterAssocData *assocPtr = afterPtr->assocPtr;
  1908.  
  1909.     if (assocPtr->firstAfterPtr == afterPtr) {
  1910.     assocPtr->firstAfterPtr = afterPtr->nextPtr;
  1911.     } else {
  1912.     for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
  1913.         prevPtr = prevPtr->nextPtr) {
  1914.         /* Empty loop body. */
  1915.     }
  1916.     prevPtr->nextPtr = afterPtr->nextPtr;
  1917.     }
  1918.     ckfree(afterPtr->command);
  1919.     ckfree((char *) afterPtr);
  1920. }
  1921.  
  1922. /*
  1923.  *----------------------------------------------------------------------
  1924.  *
  1925.  * AfterCleanupProc --
  1926.  *
  1927.  *    This procedure is invoked whenever an interpreter is deleted
  1928.  *    to cleanup the AssocData for "tclAfter".
  1929.  *
  1930.  * Results:
  1931.  *    None.
  1932.  *
  1933.  * Side effects:
  1934.  *    After commands are removed.
  1935.  *
  1936.  *----------------------------------------------------------------------
  1937.  */
  1938.  
  1939.     /* ARGSUSED */
  1940. static void
  1941. AfterCleanupProc(clientData, interp)
  1942.     ClientData clientData;    /* Points to AfterAssocData for the
  1943.                  * interpreter. */
  1944.     Tcl_Interp *interp;        /* Interpreter that is being deleted. */
  1945. {
  1946.     AfterAssocData *assocPtr = (AfterAssocData *) clientData;
  1947.     AfterInfo *afterPtr;
  1948.  
  1949.     while (assocPtr->firstAfterPtr != NULL) {
  1950.     afterPtr = assocPtr->firstAfterPtr;
  1951.     assocPtr->firstAfterPtr = afterPtr->nextPtr;
  1952.     if (afterPtr->token != NULL) {
  1953.         Tcl_DeleteTimerHandler(afterPtr->token);
  1954.     } else {
  1955.         Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
  1956.     }
  1957.     ckfree(afterPtr->command);
  1958.     ckfree((char *) afterPtr);
  1959.     }
  1960.     ckfree((char *) assocPtr);
  1961. }
  1962.  
  1963. /*
  1964.  *----------------------------------------------------------------------
  1965.  *
  1966.  * Tcl_VwaitCmd --
  1967.  *
  1968.  *    This procedure is invoked to process the "vwait" Tcl command.
  1969.  *    See the user documentation for details on what it does.
  1970.  *
  1971.  * Results:
  1972.  *    A standard Tcl result.
  1973.  *
  1974.  * Side effects:
  1975.  *    See the user documentation.
  1976.  *
  1977.  *----------------------------------------------------------------------
  1978.  */
  1979.  
  1980.     /* ARGSUSED */
  1981. int
  1982. Tcl_VwaitCmd(clientData, interp, argc, argv)
  1983.     ClientData clientData;    /* Not used. */
  1984.     Tcl_Interp *interp;        /* Current interpreter. */
  1985.     int argc;            /* Number of arguments. */
  1986.     char **argv;        /* Argument strings. */
  1987. {
  1988.     int done, foundEvent;
  1989.  
  1990.     if (argc != 2) {
  1991.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1992.         argv[0], " name\"", (char *) NULL);
  1993.     return TCL_ERROR;
  1994.     }
  1995.     Tcl_TraceVar(interp, argv[1],
  1996.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  1997.         VwaitVarProc, (ClientData) &done);
  1998.     done = 0;
  1999.     foundEvent = 1;
  2000.     while (!done && foundEvent) {
  2001.     foundEvent = Tcl_DoOneEvent(0);
  2002.     }
  2003.     Tcl_UntraceVar(interp, argv[1],
  2004.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  2005.         VwaitVarProc, (ClientData) &done);
  2006.  
  2007.     /*
  2008.      * Clear out the interpreter's result, since it may have been set
  2009.      * by event handlers.
  2010.      */
  2011.  
  2012.     Tcl_ResetResult(interp);
  2013.     if (!foundEvent) {
  2014.     Tcl_AppendResult(interp, "can't wait for variable \"", argv[1],
  2015.         "\":  would wait forever", (char *) NULL);
  2016.     return TCL_ERROR;
  2017.     }
  2018.     return TCL_OK;
  2019. }
  2020.  
  2021.     /* ARGSUSED */
  2022. static char *
  2023. VwaitVarProc(clientData, interp, name1, name2, flags)
  2024.     ClientData clientData;    /* Pointer to integer to set to 1. */
  2025.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2026.     char *name1;        /* Name of variable. */
  2027.     char *name2;        /* Second part of variable name. */
  2028.     int flags;            /* Information about what happened. */
  2029. {
  2030.     int *donePtr = (int *) clientData;
  2031.  
  2032.     *donePtr = 1;
  2033.     return (char *) NULL;
  2034. }
  2035.  
  2036. /*
  2037.  *----------------------------------------------------------------------
  2038.  *
  2039.  * Tcl_UpdateCmd --
  2040.  *
  2041.  *    This procedure is invoked to process the "update" Tcl command.
  2042.  *    See the user documentation for details on what it does.
  2043.  *
  2044.  * Results:
  2045.  *    A standard Tcl result.
  2046.  *
  2047.  * Side effects:
  2048.  *    See the user documentation.
  2049.  *
  2050.  *----------------------------------------------------------------------
  2051.  */
  2052.  
  2053.     /* ARGSUSED */
  2054. int
  2055. Tcl_UpdateCmd(clientData, interp, argc, argv)
  2056.     ClientData clientData;    /* Not used. */
  2057.     Tcl_Interp *interp;        /* Current interpreter. */
  2058.     int argc;            /* Number of arguments. */
  2059.     char **argv;        /* Argument strings. */
  2060. {
  2061.     int flags = 0;        /* Initialization needed only to stop
  2062.                  * compiler warnings. */
  2063.  
  2064.     if (argc == 1) {
  2065.     flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
  2066.     } else if (argc == 2) {
  2067.     if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) {
  2068.         Tcl_AppendResult(interp, "bad option \"", argv[1],
  2069.             "\": must be idletasks", (char *) NULL);
  2070.         return TCL_ERROR;
  2071.     }
  2072.     flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
  2073.     } else {
  2074.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  2075.         argv[0], " ?idletasks?\"", (char *) NULL);
  2076.     return TCL_ERROR;
  2077.     }
  2078.  
  2079.     while (Tcl_DoOneEvent(flags) != 0) {
  2080.     /* Empty loop body */
  2081.     }
  2082.  
  2083.     /*
  2084.      * Must clear the interpreter's result because event handlers could
  2085.      * have executed commands.
  2086.      */
  2087.  
  2088.     Tcl_ResetResult(interp);
  2089.     return TCL_OK;
  2090. }
  2091.  
  2092. /*
  2093.  *----------------------------------------------------------------------
  2094.  *
  2095.  * TclWaitForFile --
  2096.  *
  2097.  *    This procedure waits synchronously for a file to become readable
  2098.  *    or writable, with an optional timeout.
  2099.  *
  2100.  * Results:
  2101.  *    The return value is an OR'ed combination of TCL_READABLE,
  2102.  *    TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions
  2103.  *    that are present on file at the time of the return.  This
  2104.  *    procedure will not return until either "timeout" milliseconds
  2105.  *    have elapsed or at least one of the conditions given by mask
  2106.  *    has occurred for file (a return value of 0 means that a timeout
  2107.  *    occurred).  No normal events will be serviced during the
  2108.  *    execution of this procedure.
  2109.  *
  2110.  * Side effects:
  2111.  *    Time passes.
  2112.  *
  2113.  *----------------------------------------------------------------------
  2114.  */
  2115.  
  2116. int
  2117. TclWaitForFile(file, mask, timeout)
  2118.     Tcl_File file;        /* Handle for file on which to wait. */
  2119.     int mask;            /* What to wait for: OR'ed combination of
  2120.                  * TCL_READABLE, TCL_WRITABLE, and
  2121.                  * TCL_EXCEPTION. */
  2122.     int timeout;        /* Maximum amount of time to wait for one
  2123.                  * of the conditions in mask to occur, in
  2124.                  * milliseconds.  A value of 0 means don't
  2125.                  * wait at all, and a value of -1 means
  2126.                  * wait forever. */
  2127. {
  2128.     Tcl_Time abortTime, now, blockTime;
  2129.     int present;
  2130.  
  2131.     /*
  2132.      * If there is a non-zero finite timeout, compute the time when
  2133.      * we give up.
  2134.      */
  2135.  
  2136.     if (timeout > 0) {
  2137.     TclGetTime(&now);
  2138.     abortTime.sec = now.sec + timeout/1000;
  2139.     abortTime.usec = now.usec + (timeout%1000)*1000;
  2140.     if (abortTime.usec >= 1000000) {
  2141.         abortTime.usec -= 1000000;
  2142.         abortTime.sec += 1;
  2143.     }
  2144.     }
  2145.  
  2146.     /*
  2147.      * Loop in a mini-event loop of our own, waiting for either the
  2148.      * file to become ready or a timeout to occur.
  2149.      */
  2150.  
  2151.     while (1) {
  2152.     Tcl_WatchFile(file, mask);
  2153.     if (timeout > 0) {
  2154.         blockTime.sec = abortTime.sec - now.sec;
  2155.         blockTime.usec = abortTime.usec - now.usec;
  2156.         if (blockTime.usec < 0) {
  2157.         blockTime.sec -= 1;
  2158.         blockTime.usec += 1000000;
  2159.         }
  2160.         if (blockTime.sec < 0) {
  2161.         blockTime.sec = 0;
  2162.         blockTime.usec = 0;
  2163.         }
  2164.         Tcl_WaitForEvent(&blockTime);
  2165.     } else if (timeout == 0) {
  2166.         blockTime.sec = 0;
  2167.         blockTime.usec = 0;
  2168.         Tcl_WaitForEvent(&blockTime);
  2169.     } else {
  2170.         Tcl_WaitForEvent((Tcl_Time *) NULL);
  2171.     }
  2172.     present = Tcl_FileReady(file, mask);
  2173.     if (present != 0) {
  2174.         break;
  2175.     }
  2176.     if (timeout == 0) {
  2177.         break;
  2178.     }
  2179.     TclGetTime(&now);
  2180.     if ((abortTime.sec < now.sec)
  2181.         || ((abortTime.sec == now.sec)
  2182.         && (abortTime.usec <= now.usec))) {
  2183.         break;
  2184.     }
  2185.     }
  2186.     return present;
  2187. }
  2188.