/[dtapublic]/projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c
ViewVC logotype

Diff of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c revision 44 by dashley, Fri Oct 14 02:09:58 2016 UTC projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c revision 98 by dashley, Sun Dec 18 00:57:31 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclevent.c,v 1.1.1.1 2001/06/13 04:38:05 dtashley Exp $ */  
   
 /*  
  * tclEvent.c --  
  *  
  *      This file implements some general event related interfaces including  
  *      background errors, exit handlers, and the "vwait" and "update"  
  *      command procedures.  
  *  
  * Copyright (c) 1990-1994 The Regents of the University of California.  
  * Copyright (c) 1994-1998 Sun Microsystems, Inc.  
  *  
  * See the file "license.terms" for information on usage and redistribution  
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.  
  *  
  * RCS: @(#) $Id: tclevent.c,v 1.1.1.1 2001/06/13 04:38:05 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclPort.h"  
   
 /*  
  * 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;             /* Copy of the error message (the interp's  
                                  * 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;  
   
 /*  
  * There is both per-process and per-thread exit handlers.  
  * The first list is controlled by a mutex.  The other is in  
  * thread local storage.  
  */  
   
 static ExitHandler *firstExitPtr = NULL;  
                                 /* First in list of all exit handlers for  
                                  * application. */  
 TCL_DECLARE_MUTEX(exitMutex)  
   
 /*  
  * This variable is set to 1 when Tcl_Finalize is called, and at the end of  
  * its work, it is reset to 0. The variable is checked by TclInExit() to  
  * allow different behavior for exit-time processing, e.g. in closing of  
  * files and pipes.  
  */  
   
 static int inFinalize = 0;  
 static int subsystemsInitialized = 0;  
   
 typedef struct ThreadSpecificData {  
     ExitHandler *firstExitPtr;  /* First in list of all exit handlers for  
                                  * this thread. */  
     int inExit;                 /* True when this thread is exiting. This  
                                  * is used as a hack to decide to close  
                                  * the standard channels. */  
     Tcl_Obj *tclLibraryPath;    /* Path(s) to the Tcl library */  
 } ThreadSpecificData;  
 static Tcl_ThreadDataKey dataKey;  
   
 /*  
  * Prototypes for procedures referenced only in this file:  
  */  
   
 static void             BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,  
                             Tcl_Interp *interp));  
 static void             HandleBgErrors _ANSI_ARGS_((ClientData clientData));  
 static char *           VwaitVarProc _ANSI_ARGS_((ClientData clientData,  
                             Tcl_Interp *interp, char *name1, char *name2,  
                             int flags));  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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 *errResult, *varValue;  
     ErrAssocData *assocPtr;  
     int length;  
   
     /*  
      * 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, "");  
   
     errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);  
           
     errPtr = (BgError *) ckalloc(sizeof(BgError));  
     errPtr->interp = interp;  
     errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));  
     memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));  
     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 *argv[2];  
     int code;  
     BgError *errPtr;  
     ErrAssocData *assocPtr = (ErrAssocData *) clientData;  
     Tcl_Channel errChannel;  
   
     Tcl_Preserve((ClientData) assocPtr);  
       
     while (assocPtr->firstBgPtr != NULL) {  
         interp = assocPtr->firstBgPtr->interp;  
         if (interp == NULL) {  
             goto doneWithInterp;  
         }  
   
         /*  
          * 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;  
           
         Tcl_AllowExceptions(interp);  
         Tcl_Preserve((ClientData) interp);  
         code = TclGlobalInvoke(interp, 2, argv, 0);  
         if (code == TCL_ERROR) {  
   
             /*  
              * If the interpreter is safe, we look for a hidden command  
              * named "bgerror" and call that with the error information.  
              * Otherwise, simply ignore the error. The rationale is that  
              * this could be an error caused by a malicious applet trying  
              * to cause an infinite barrage of error messages. The hidden  
              * "bgerror" command can be used by a security policy to  
              * interpose on such attacks and e.g. kill the applet after a  
              * few attempts.  
              */  
   
             if (Tcl_IsSafe(interp)) {  
                 Tcl_SavedResult save;  
                   
                 Tcl_SaveResult(interp, &save);  
                 TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);  
                 Tcl_RestoreResult(interp, &save);  
   
                 goto doneWithInterp;  
             }  
   
             /*  
              * 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) {  
                 char *string;  
                 int len;  
   
                 string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);  
                 if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) {  
                     Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);  
                     Tcl_WriteChars(errChannel, "\n", -1);  
                 } else {  
                     Tcl_WriteChars(errChannel,  
                             "bgerror failed to handle background error.\n",  
                             -1);  
                     Tcl_WriteChars(errChannel, "    Original error: ", -1);  
                     Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,  
                             -1);  
                     Tcl_WriteChars(errChannel, "\n", -1);  
                     Tcl_WriteChars(errChannel, "    Error in bgerror: ", -1);  
                     Tcl_WriteChars(errChannel, string, len);  
                     Tcl_WriteChars(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;  
                 }  
             }  
         }  
   
         /*  
          * Discard the command and the information about the error report.  
          */  
   
 doneWithInterp:  
   
         if (assocPtr->firstBgPtr) {  
             ckfree(assocPtr->firstBgPtr->errorMsg);  
             ckfree(assocPtr->firstBgPtr->errorInfo);  
             ckfree(assocPtr->firstBgPtr->errorCode);  
             errPtr = assocPtr->firstBgPtr->nextPtr;  
             ckfree((char *) assocPtr->firstBgPtr);  
             assocPtr->firstBgPtr = errPtr;  
         }  
           
         if (interp != NULL) {  
             Tcl_Release((ClientData) interp);  
         }  
     }  
     assocPtr->lastBgPtr = NULL;  
   
     Tcl_Release((ClientData) assocPtr);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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);  
     }  
     Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);  
     Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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;  
     Tcl_MutexLock(&exitMutex);  
     exitPtr->nextPtr = firstExitPtr;  
     firstExitPtr = exitPtr;  
     Tcl_MutexUnlock(&exitMutex);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * 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;  
   
     Tcl_MutexLock(&exitMutex);  
     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);  
             break;  
         }  
     }  
     Tcl_MutexUnlock(&exitMutex);  
     return;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_CreateThreadExitHandler --  
  *  
  *      Arrange for a given procedure to be invoked just before the  
  *      current thread exits.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Proc will be invoked with clientData as argument when the  
  *      application exits.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 Tcl_CreateThreadExitHandler(proc, clientData)  
     Tcl_ExitProc *proc;         /* Procedure to invoke. */  
     ClientData clientData;      /* Arbitrary value to pass to proc. */  
 {  
     ExitHandler *exitPtr;  
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);  
   
     exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));  
     exitPtr->proc = proc;  
     exitPtr->clientData = clientData;  
     exitPtr->nextPtr = tsdPtr->firstExitPtr;  
     tsdPtr->firstExitPtr = exitPtr;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_DeleteThreadExitHandler --  
  *  
  *      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_DeleteThreadExitHandler(proc, clientData)  
     Tcl_ExitProc *proc;         /* Procedure that was previously registered. */  
     ClientData clientData;      /* Arbitrary value to pass to proc. */  
 {  
     ExitHandler *exitPtr, *prevPtr;  
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);  
   
     for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;  
             prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {  
         if ((exitPtr->proc == proc)  
                 && (exitPtr->clientData == clientData)) {  
             if (prevPtr == NULL) {  
                 tsdPtr->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. */  
 {  
     Tcl_Finalize();  
     TclpExit(status);  
 }  
   
 /*  
  *-------------------------------------------------------------------------  
  *  
  * TclSetLibraryPath --  
  *  
  *      Set the path that will be used for searching for init.tcl and  
  *      encodings when an interp is being created.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Changing the library path will affect what directories are  
  *      examined when looking for encodings for all interps from that  
  *      point forward.  
  *  
  *      The refcount of the new library path is incremented and the  
  *      refcount of the old path is decremented.  
  *  
  *-------------------------------------------------------------------------  
  */  
   
 void  
 TclSetLibraryPath(pathPtr)  
     Tcl_Obj *pathPtr;           /* A Tcl list object whose elements are  
                                  * the new library path. */  
 {  
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);  
   
     if (pathPtr != NULL) {  
         Tcl_IncrRefCount(pathPtr);  
     }  
     if (tsdPtr->tclLibraryPath != NULL) {  
         Tcl_DecrRefCount(tsdPtr->tclLibraryPath);  
     }  
     tsdPtr->tclLibraryPath = pathPtr;  
 }  
   
 /*  
  *-------------------------------------------------------------------------  
  *  
  * TclGetLibraryPath --  
  *  
  *      Return a Tcl list object whose elements are the library path.  
  *      The caller should not modify the contents of the returned object.  
  *  
  * Results:  
  *      As above.  
  *  
  * Side effects:  
  *      None.  
  *  
  *-------------------------------------------------------------------------  
  */  
   
 Tcl_Obj *  
 TclGetLibraryPath()  
 {  
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);  
     return tsdPtr->tclLibraryPath;  
 }  
   
 /*  
  *-------------------------------------------------------------------------  
  *  
  * TclInitSubsystems --  
  *  
  *      Initialize various subsytems in Tcl.  This should be called the  
  *      first time an interp is created, or before any of the subsystems  
  *      are used.  This function ensures an order for the initialization  
  *      of subsystems:  
  *  
  *      1. that cannot be initialized in lazy order because they are  
  *      mutually dependent.  
  *  
  *      2. so that they can be finalized in a known order w/o causing  
  *      the subsequent re-initialization of a subsystem in the act of  
  *      shutting down another.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Varied, see the respective initialization routines.  
  *  
  *-------------------------------------------------------------------------  
  */  
   
 void  
 TclInitSubsystems(argv0)  
     CONST char *argv0;          /* Name of executable from argv[0] to main()  
                                  * in native multi-byte encoding. */  
 {  
     ThreadSpecificData *tsdPtr;  
   
     if (inFinalize != 0) {  
         panic("TclInitSubsystems called while finalizing");  
     }  
   
     /*  
      * Grab the thread local storage pointer before doing anything because  
      * the initialization routines will be registering exit handlers.  
      * We use this pointer to detect if this is the first time this  
      * thread has created an interpreter.  
      */  
   
     tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);  
   
     if (subsystemsInitialized == 0) {  
         /*  
          * Double check inside the mutex.  There are definitly calls  
          * back into this routine from some of the procedures below.  
          */  
   
         TclpInitLock();  
         if (subsystemsInitialized == 0) {  
             /*  
              * Have to set this bit here to avoid deadlock with the  
              * routines below us that call into TclInitSubsystems.  
              */  
   
             subsystemsInitialized = 1;  
   
             tclExecutableName = NULL;  
   
             /*  
              * Initialize locks used by the memory allocators before anything  
              * interesting happens so we can use the allocators in the  
              * implementation of self-initializing locks.  
              */  
 #if USE_TCLALLOC  
             TclInitAlloc(); /* process wide mutex init */  
 #endif  
 #ifdef TCL_MEM_DEBUG  
             TclInitDbCkalloc(); /* process wide mutex init */  
 #endif  
   
             TclpInitPlatform(); /* creates signal handler(s) */  
             TclInitObjSubsystem(); /* register obj types, create mutexes */  
             TclInitIOSubsystem(); /* inits a tsd key (noop) */  
             TclInitEncodingSubsystem(); /* process wide encoding init */  
             TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */  
         }  
         TclpInitUnlock();  
     }  
   
     if (tsdPtr == NULL) {  
         /*  
          * First time this thread has created an interpreter.  
          * We fetch the key again just in case no exit handlers were  
          * registered by this point.  
          */  
   
         (void) TCL_TSD_INIT(&dataKey);  
         TclInitNotifier();  
      }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_Finalize --  
  *  
  *      Shut down Tcl.  First calls registered exit handlers, then  
  *      carefully shuts down various subsystems.  
  *      Called by Tcl_Exit or when the Tcl shared library is being  
  *      unloaded.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Varied, see the respective finalization routines.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 Tcl_Finalize()  
 {  
     ExitHandler *exitPtr;  
     ThreadSpecificData *tsdPtr;  
   
     TclpInitLock();  
     tsdPtr = TCL_TSD_INIT(&dataKey);  
     if (subsystemsInitialized != 0) {  
         subsystemsInitialized = 0;  
   
         /*  
          * Invoke exit handlers first.  
          */  
   
         Tcl_MutexLock(&exitMutex);  
         inFinalize = 1;  
         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;  
             Tcl_MutexUnlock(&exitMutex);  
             (*exitPtr->proc)(exitPtr->clientData);  
             ckfree((char *) exitPtr);  
             Tcl_MutexLock(&exitMutex);  
         }      
         firstExitPtr = NULL;  
         Tcl_MutexUnlock(&exitMutex);  
   
         /*  
          * Clean up the library path now, before we invalidate thread-local  
          * storage.  
          */  
         if (tsdPtr->tclLibraryPath != NULL) {  
             Tcl_DecrRefCount(tsdPtr->tclLibraryPath);  
             tsdPtr->tclLibraryPath = NULL;  
         }  
   
         /*  
          * Clean up after the current thread now, after exit handlers.  
          * In particular, the testexithandler command sets up something  
          * that writes to standard output, which gets closed.  
          * Note that there is no thread-local storage after this call.  
          */  
   
         Tcl_FinalizeThread();  
   
         /*  
          * Now finalize the Tcl execution environment.  Note that this  
          * must be done after the exit handlers, because there are  
          * order dependencies.  
          */  
   
         TclFinalizeCompExecEnv();  
         TclFinalizeEnvironment();  
   
         TclFinalizeEncodingSubsystem();  
   
         if (tclExecutableName != NULL) {  
             ckfree(tclExecutableName);  
             tclExecutableName = NULL;  
         }  
         if (tclNativeExecutableName != NULL) {  
             ckfree(tclNativeExecutableName);  
             tclNativeExecutableName = NULL;  
         }  
         if (tclDefaultEncodingDir != NULL) {  
             ckfree(tclDefaultEncodingDir);  
             tclDefaultEncodingDir = NULL;  
         }  
           
         Tcl_SetPanicProc(NULL);  
   
         /*  
          * Free synchronization objects.  There really should only be one  
          * thread alive at this moment.  
          */  
   
         TclFinalizeSynchronization();  
   
         /*  
          * We defer unloading of packages until very late  
          * to avoid memory access issues.  Both exit callbacks and  
          * synchronization variables may be stored in packages.  
          */  
   
         TclFinalizeLoad();  
   
         /*  
          * There shouldn't be any malloc'ed memory after this.  
          */  
   
         TclFinalizeMemorySubsystem();  
         inFinalize = 0;  
     }  
     TclpInitUnlock();  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_FinalizeThread --  
  *  
  *      Runs the exit handlers to allow Tcl to clean up its state  
  *      about a particular thread.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Varied, see the respective finalization routines.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 Tcl_FinalizeThread()  
 {  
     ExitHandler *exitPtr;  
     ThreadSpecificData *tsdPtr =  
             (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);  
   
     if (tsdPtr != NULL) {  
         /*  
          * Invoke thread exit handlers first.  
          */  
   
         tsdPtr->inExit = 1;  
         for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;  
                 exitPtr = tsdPtr->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_DeleteThreadExitHandler on itself.  
              */  
   
             tsdPtr->firstExitPtr = exitPtr->nextPtr;  
             (*exitPtr->proc)(exitPtr->clientData);  
             ckfree((char *) exitPtr);  
         }  
         TclFinalizeIOSubsystem();  
         TclFinalizeNotifier();  
   
         /*  
          * Blow away all thread local storage blocks.  
          */  
   
         TclFinalizeThreadData();  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclInExit --  
  *  
  *      Determines if we are in the middle of exit-time cleanup.  
  *  
  * Results:  
  *      If we are in the middle of exiting, 1, otherwise 0.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclInExit()  
 {  
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);  
     return tsdPtr->inExit;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * Tcl_VwaitObjCmd --  
  *  
  *      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_VwaitObjCmd(clientData, interp, objc, objv)  
     ClientData clientData;      /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     int done, foundEvent;  
     char *nameString;  
   
     if (objc != 2) {  
         Tcl_WrongNumArgs(interp, 1, objv, "name");  
         return TCL_ERROR;  
     }  
     nameString = Tcl_GetString(objv[1]);  
     if (Tcl_TraceVar(interp, nameString,  
             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(TCL_ALL_EVENTS);  
     }  
     Tcl_UntraceVar(interp, nameString,  
             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 \"", nameString,  
                 "\":  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_UpdateObjCmd --  
  *  
  *      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_UpdateObjCmd(clientData, interp, objc, objv)  
     ClientData clientData;      /* Not used. */  
     Tcl_Interp *interp;         /* Current interpreter. */  
     int objc;                   /* Number of arguments. */  
     Tcl_Obj *CONST objv[];      /* Argument objects. */  
 {  
     int optionIndex;  
     int flags = 0;              /* Initialized to avoid compiler warning. */  
     static char *updateOptions[] = {"idletasks", (char *) NULL};  
     enum updateOptions {REGEXP_IDLETASKS};  
   
     if (objc == 1) {  
         flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;  
     } else if (objc == 2) {  
         if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,  
                 "option", 0, &optionIndex) != TCL_OK) {  
             return TCL_ERROR;  
         }  
         switch ((enum updateOptions) optionIndex) {  
             case REGEXP_IDLETASKS: {  
                 flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;  
                 break;  
             }  
             default: {  
                 panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");  
             }  
         }  
     } else {  
         Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");  
         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;  
 }  
   
   
 /* $History: tclevent.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:26a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLEVENT.C */  
1    /* $Header$ */
2    /*
3     * tclEvent.c --
4     *
5     *      This file implements some general event related interfaces including
6     *      background errors, exit handlers, and the "vwait" and "update"
7     *      command procedures.
8     *
9     * Copyright (c) 1990-1994 The Regents of the University of California.
10     * Copyright (c) 1994-1998 Sun Microsystems, Inc.
11     *
12     * See the file "license.terms" for information on usage and redistribution
13     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14     *
15     * RCS: @(#) $Id: tclevent.c,v 1.1.1.1 2001/06/13 04:38:05 dtashley Exp $
16     */
17    
18    #include "tclInt.h"
19    #include "tclPort.h"
20    
21    /*
22     * The data structure below is used to report background errors.  One
23     * such structure is allocated for each error;  it holds information
24     * about the interpreter and the error until bgerror can be invoked
25     * later as an idle handler.
26     */
27    
28    typedef struct BgError {
29        Tcl_Interp *interp;         /* Interpreter in which error occurred.  NULL
30                                     * means this error report has been cancelled
31                                     * (a previous report generated a break). */
32        char *errorMsg;             /* Copy of the error message (the interp's
33                                     * result when the error occurred).
34                                     * Malloc-ed. */
35        char *errorInfo;            /* Value of the errorInfo variable
36                                     * (malloc-ed). */
37        char *errorCode;            /* Value of the errorCode variable
38                                     * (malloc-ed). */
39        struct BgError *nextPtr;    /* Next in list of all pending error
40                                     * reports for this interpreter, or NULL
41                                     * for end of list. */
42    } BgError;
43    
44    /*
45     * One of the structures below is associated with the "tclBgError"
46     * assoc data for each interpreter.  It keeps track of the head and
47     * tail of the list of pending background errors for the interpreter.
48     */
49    
50    typedef struct ErrAssocData {
51        BgError *firstBgPtr;        /* First in list of all background errors
52                                     * waiting to be processed for this
53                                     * interpreter (NULL if none). */
54        BgError *lastBgPtr;         /* Last in list of all background errors
55                                     * waiting to be processed for this
56                                     * interpreter (NULL if none). */
57    } ErrAssocData;
58    
59    /*
60     * For each exit handler created with a call to Tcl_CreateExitHandler
61     * there is a structure of the following type:
62     */
63    
64    typedef struct ExitHandler {
65        Tcl_ExitProc *proc;         /* Procedure to call when process exits. */
66        ClientData clientData;      /* One word of information to pass to proc. */
67        struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
68                                     * this application, or NULL for end of list. */
69    } ExitHandler;
70    
71    /*
72     * There is both per-process and per-thread exit handlers.
73     * The first list is controlled by a mutex.  The other is in
74     * thread local storage.
75     */
76    
77    static ExitHandler *firstExitPtr = NULL;
78                                    /* First in list of all exit handlers for
79                                     * application. */
80    TCL_DECLARE_MUTEX(exitMutex)
81    
82    /*
83     * This variable is set to 1 when Tcl_Finalize is called, and at the end of
84     * its work, it is reset to 0. The variable is checked by TclInExit() to
85     * allow different behavior for exit-time processing, e.g. in closing of
86     * files and pipes.
87     */
88    
89    static int inFinalize = 0;
90    static int subsystemsInitialized = 0;
91    
92    typedef struct ThreadSpecificData {
93        ExitHandler *firstExitPtr;  /* First in list of all exit handlers for
94                                     * this thread. */
95        int inExit;                 /* True when this thread is exiting. This
96                                     * is used as a hack to decide to close
97                                     * the standard channels. */
98        Tcl_Obj *tclLibraryPath;    /* Path(s) to the Tcl library */
99    } ThreadSpecificData;
100    static Tcl_ThreadDataKey dataKey;
101    
102    /*
103     * Prototypes for procedures referenced only in this file:
104     */
105    
106    static void             BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
107                                Tcl_Interp *interp));
108    static void             HandleBgErrors _ANSI_ARGS_((ClientData clientData));
109    static char *           VwaitVarProc _ANSI_ARGS_((ClientData clientData,
110                                Tcl_Interp *interp, char *name1, char *name2,
111                                int flags));
112    
113    /*
114     *----------------------------------------------------------------------
115     *
116     * Tcl_BackgroundError --
117     *
118     *      This procedure is invoked to handle errors that occur in Tcl
119     *      commands that are invoked in "background" (e.g. from event or
120     *      timer bindings).
121     *
122     * Results:
123     *      None.
124     *
125     * Side effects:
126     *      The command "bgerror" is invoked later as an idle handler to
127     *      process the error, passing it the error message.  If that fails,
128     *      then an error message is output on stderr.
129     *
130     *----------------------------------------------------------------------
131     */
132    
133    void
134    Tcl_BackgroundError(interp)
135        Tcl_Interp *interp;         /* Interpreter in which an error has
136                                     * occurred. */
137    {
138        BgError *errPtr;
139        char *errResult, *varValue;
140        ErrAssocData *assocPtr;
141        int length;
142    
143        /*
144         * The Tcl_AddErrorInfo call below (with an empty string) ensures that
145         * errorInfo gets properly set.  It's needed in cases where the error
146         * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
147         * in these cases errorInfo still won't have been set when this
148         * procedure is called.
149         */
150    
151        Tcl_AddErrorInfo(interp, "");
152    
153        errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
154            
155        errPtr = (BgError *) ckalloc(sizeof(BgError));
156        errPtr->interp = interp;
157        errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
158        memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
159        varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
160        if (varValue == NULL) {
161            varValue = errPtr->errorMsg;
162        }
163        errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
164        strcpy(errPtr->errorInfo, varValue);
165        varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
166        if (varValue == NULL) {
167            varValue = "";
168        }
169        errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
170        strcpy(errPtr->errorCode, varValue);
171        errPtr->nextPtr = NULL;
172    
173        assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
174                (Tcl_InterpDeleteProc **) NULL);
175        if (assocPtr == NULL) {
176    
177            /*
178             * This is the first time a background error has occurred in
179             * this interpreter.  Create associated data to keep track of
180             * pending error reports.
181             */
182    
183            assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
184            assocPtr->firstBgPtr = NULL;
185            assocPtr->lastBgPtr = NULL;
186            Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
187                    (ClientData) assocPtr);
188        }
189        if (assocPtr->firstBgPtr == NULL) {
190            assocPtr->firstBgPtr = errPtr;
191            Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
192        } else {
193            assocPtr->lastBgPtr->nextPtr = errPtr;
194        }
195        assocPtr->lastBgPtr = errPtr;
196        Tcl_ResetResult(interp);
197    }
198    
199    /*
200     *----------------------------------------------------------------------
201     *
202     * HandleBgErrors --
203     *
204     *      This procedure is invoked as an idle handler to process all of
205     *      the accumulated background errors.
206     *
207     * Results:
208     *      None.
209     *
210     * Side effects:
211     *      Depends on what actions "bgerror" takes for the errors.
212     *
213     *----------------------------------------------------------------------
214     */
215    
216    static void
217    HandleBgErrors(clientData)
218        ClientData clientData;      /* Pointer to ErrAssocData structure. */
219    {
220        Tcl_Interp *interp;
221        char *argv[2];
222        int code;
223        BgError *errPtr;
224        ErrAssocData *assocPtr = (ErrAssocData *) clientData;
225        Tcl_Channel errChannel;
226    
227        Tcl_Preserve((ClientData) assocPtr);
228        
229        while (assocPtr->firstBgPtr != NULL) {
230            interp = assocPtr->firstBgPtr->interp;
231            if (interp == NULL) {
232                goto doneWithInterp;
233            }
234    
235            /*
236             * Restore important state variables to what they were at
237             * the time the error occurred.
238             */
239    
240            Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
241                    TCL_GLOBAL_ONLY);
242            Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
243                    TCL_GLOBAL_ONLY);
244    
245            /*
246             * Create and invoke the bgerror command.
247             */
248    
249            argv[0] = "bgerror";
250            argv[1] = assocPtr->firstBgPtr->errorMsg;
251            
252            Tcl_AllowExceptions(interp);
253            Tcl_Preserve((ClientData) interp);
254            code = TclGlobalInvoke(interp, 2, argv, 0);
255            if (code == TCL_ERROR) {
256    
257                /*
258                 * If the interpreter is safe, we look for a hidden command
259                 * named "bgerror" and call that with the error information.
260                 * Otherwise, simply ignore the error. The rationale is that
261                 * this could be an error caused by a malicious applet trying
262                 * to cause an infinite barrage of error messages. The hidden
263                 * "bgerror" command can be used by a security policy to
264                 * interpose on such attacks and e.g. kill the applet after a
265                 * few attempts.
266                 */
267    
268                if (Tcl_IsSafe(interp)) {
269                    Tcl_SavedResult save;
270                    
271                    Tcl_SaveResult(interp, &save);
272                    TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
273                    Tcl_RestoreResult(interp, &save);
274    
275                    goto doneWithInterp;
276                }
277    
278                /*
279                 * We have to get the error output channel at the latest possible
280                 * time, because the eval (above) might have changed the channel.
281                 */
282                
283                errChannel = Tcl_GetStdChannel(TCL_STDERR);
284                if (errChannel != (Tcl_Channel) NULL) {
285                    char *string;
286                    int len;
287    
288                    string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
289                    if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) {
290                        Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
291                        Tcl_WriteChars(errChannel, "\n", -1);
292                    } else {
293                        Tcl_WriteChars(errChannel,
294                                "bgerror failed to handle background error.\n",
295                                -1);
296                        Tcl_WriteChars(errChannel, "    Original error: ", -1);
297                        Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
298                                -1);
299                        Tcl_WriteChars(errChannel, "\n", -1);
300                        Tcl_WriteChars(errChannel, "    Error in bgerror: ", -1);
301                        Tcl_WriteChars(errChannel, string, len);
302                        Tcl_WriteChars(errChannel, "\n", -1);
303                    }
304                    Tcl_Flush(errChannel);
305                }
306            } else if (code == TCL_BREAK) {
307    
308                /*
309                 * Break means cancel any remaining error reports for this
310                 * interpreter.
311                 */
312    
313                for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
314                        errPtr = errPtr->nextPtr) {
315                    if (errPtr->interp == interp) {
316                        errPtr->interp = NULL;
317                    }
318                }
319            }
320    
321            /*
322             * Discard the command and the information about the error report.
323             */
324    
325    doneWithInterp:
326    
327            if (assocPtr->firstBgPtr) {
328                ckfree(assocPtr->firstBgPtr->errorMsg);
329                ckfree(assocPtr->firstBgPtr->errorInfo);
330                ckfree(assocPtr->firstBgPtr->errorCode);
331                errPtr = assocPtr->firstBgPtr->nextPtr;
332                ckfree((char *) assocPtr->firstBgPtr);
333                assocPtr->firstBgPtr = errPtr;
334            }
335            
336            if (interp != NULL) {
337                Tcl_Release((ClientData) interp);
338            }
339        }
340        assocPtr->lastBgPtr = NULL;
341    
342        Tcl_Release((ClientData) assocPtr);
343    }
344    
345    /*
346     *----------------------------------------------------------------------
347     *
348     * BgErrorDeleteProc --
349     *
350     *      This procedure is associated with the "tclBgError" assoc data
351     *      for an interpreter;  it is invoked when the interpreter is
352     *      deleted in order to free the information assoicated with any
353     *      pending error reports.
354     *
355     * Results:
356     *      None.
357     *
358     * Side effects:
359     *      Background error information is freed: if there were any
360     *      pending error reports, they are cancelled.
361     *
362     *----------------------------------------------------------------------
363     */
364    
365    static void
366    BgErrorDeleteProc(clientData, interp)
367        ClientData clientData;      /* Pointer to ErrAssocData structure. */
368        Tcl_Interp *interp;         /* Interpreter being deleted. */
369    {
370        ErrAssocData *assocPtr = (ErrAssocData *) clientData;
371        BgError *errPtr;
372    
373        while (assocPtr->firstBgPtr != NULL) {
374            errPtr = assocPtr->firstBgPtr;
375            assocPtr->firstBgPtr = errPtr->nextPtr;
376            ckfree(errPtr->errorMsg);
377            ckfree(errPtr->errorInfo);
378            ckfree(errPtr->errorCode);
379            ckfree((char *) errPtr);
380        }
381        Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
382        Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
383    }
384    
385    /*
386     *----------------------------------------------------------------------
387     *
388     * Tcl_CreateExitHandler --
389     *
390     *      Arrange for a given procedure to be invoked just before the
391     *      application exits.
392     *
393     * Results:
394     *      None.
395     *
396     * Side effects:
397     *      Proc will be invoked with clientData as argument when the
398     *      application exits.
399     *
400     *----------------------------------------------------------------------
401     */
402    
403    void
404    Tcl_CreateExitHandler(proc, clientData)
405        Tcl_ExitProc *proc;         /* Procedure to invoke. */
406        ClientData clientData;      /* Arbitrary value to pass to proc. */
407    {
408        ExitHandler *exitPtr;
409    
410        exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
411        exitPtr->proc = proc;
412        exitPtr->clientData = clientData;
413        Tcl_MutexLock(&exitMutex);
414        exitPtr->nextPtr = firstExitPtr;
415        firstExitPtr = exitPtr;
416        Tcl_MutexUnlock(&exitMutex);
417    }
418    
419    /*
420     *----------------------------------------------------------------------
421     *
422     * Tcl_DeleteExitHandler --
423     *
424     *      This procedure cancels an existing exit handler matching proc
425     *      and clientData, if such a handler exits.
426     *
427     * Results:
428     *      None.
429     *
430     * Side effects:
431     *      If there is an exit handler corresponding to proc and clientData
432     *      then it is cancelled;  if no such handler exists then nothing
433     *      happens.
434     *
435     *----------------------------------------------------------------------
436     */
437    
438    void
439    Tcl_DeleteExitHandler(proc, clientData)
440        Tcl_ExitProc *proc;         /* Procedure that was previously registered. */
441        ClientData clientData;      /* Arbitrary value to pass to proc. */
442    {
443        ExitHandler *exitPtr, *prevPtr;
444    
445        Tcl_MutexLock(&exitMutex);
446        for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
447                prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
448            if ((exitPtr->proc == proc)
449                    && (exitPtr->clientData == clientData)) {
450                if (prevPtr == NULL) {
451                    firstExitPtr = exitPtr->nextPtr;
452                } else {
453                    prevPtr->nextPtr = exitPtr->nextPtr;
454                }
455                ckfree((char *) exitPtr);
456                break;
457            }
458        }
459        Tcl_MutexUnlock(&exitMutex);
460        return;
461    }
462    
463    /*
464     *----------------------------------------------------------------------
465     *
466     * Tcl_CreateThreadExitHandler --
467     *
468     *      Arrange for a given procedure to be invoked just before the
469     *      current thread exits.
470     *
471     * Results:
472     *      None.
473     *
474     * Side effects:
475     *      Proc will be invoked with clientData as argument when the
476     *      application exits.
477     *
478     *----------------------------------------------------------------------
479     */
480    
481    void
482    Tcl_CreateThreadExitHandler(proc, clientData)
483        Tcl_ExitProc *proc;         /* Procedure to invoke. */
484        ClientData clientData;      /* Arbitrary value to pass to proc. */
485    {
486        ExitHandler *exitPtr;
487        ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
488    
489        exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
490        exitPtr->proc = proc;
491        exitPtr->clientData = clientData;
492        exitPtr->nextPtr = tsdPtr->firstExitPtr;
493        tsdPtr->firstExitPtr = exitPtr;
494    }
495    
496    /*
497     *----------------------------------------------------------------------
498     *
499     * Tcl_DeleteThreadExitHandler --
500     *
501     *      This procedure cancels an existing exit handler matching proc
502     *      and clientData, if such a handler exits.
503     *
504     * Results:
505     *      None.
506     *
507     * Side effects:
508     *      If there is an exit handler corresponding to proc and clientData
509     *      then it is cancelled;  if no such handler exists then nothing
510     *      happens.
511     *
512     *----------------------------------------------------------------------
513     */
514    
515    void
516    Tcl_DeleteThreadExitHandler(proc, clientData)
517        Tcl_ExitProc *proc;         /* Procedure that was previously registered. */
518        ClientData clientData;      /* Arbitrary value to pass to proc. */
519    {
520        ExitHandler *exitPtr, *prevPtr;
521        ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
522    
523        for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
524                prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
525            if ((exitPtr->proc == proc)
526                    && (exitPtr->clientData == clientData)) {
527                if (prevPtr == NULL) {
528                    tsdPtr->firstExitPtr = exitPtr->nextPtr;
529                } else {
530                    prevPtr->nextPtr = exitPtr->nextPtr;
531                }
532                ckfree((char *) exitPtr);
533                return;
534            }
535        }
536    }
537    
538    /*
539     *----------------------------------------------------------------------
540     *
541     * Tcl_Exit --
542     *
543     *      This procedure is called to terminate the application.
544     *
545     * Results:
546     *      None.
547     *
548     * Side effects:
549     *      All existing exit handlers are invoked, then the application
550     *      ends.
551     *
552     *----------------------------------------------------------------------
553     */
554    
555    void
556    Tcl_Exit(status)
557        int status;                 /* Exit status for application;  typically
558                                     * 0 for normal return, 1 for error return. */
559    {
560        Tcl_Finalize();
561        TclpExit(status);
562    }
563    
564    /*
565     *-------------------------------------------------------------------------
566     *
567     * TclSetLibraryPath --
568     *
569     *      Set the path that will be used for searching for init.tcl and
570     *      encodings when an interp is being created.
571     *
572     * Results:
573     *      None.
574     *
575     * Side effects:
576     *      Changing the library path will affect what directories are
577     *      examined when looking for encodings for all interps from that
578     *      point forward.
579     *
580     *      The refcount of the new library path is incremented and the
581     *      refcount of the old path is decremented.
582     *
583     *-------------------------------------------------------------------------
584     */
585    
586    void
587    TclSetLibraryPath(pathPtr)
588        Tcl_Obj *pathPtr;           /* A Tcl list object whose elements are
589                                     * the new library path. */
590    {
591        ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
592    
593        if (pathPtr != NULL) {
594            Tcl_IncrRefCount(pathPtr);
595        }
596        if (tsdPtr->tclLibraryPath != NULL) {
597            Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
598        }
599        tsdPtr->tclLibraryPath = pathPtr;
600    }
601    
602    /*
603     *-------------------------------------------------------------------------
604     *
605     * TclGetLibraryPath --
606     *
607     *      Return a Tcl list object whose elements are the library path.
608     *      The caller should not modify the contents of the returned object.
609     *
610     * Results:
611     *      As above.
612     *
613     * Side effects:
614     *      None.
615     *
616     *-------------------------------------------------------------------------
617     */
618    
619    Tcl_Obj *
620    TclGetLibraryPath()
621    {
622        ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
623        return tsdPtr->tclLibraryPath;
624    }
625    
626    /*
627     *-------------------------------------------------------------------------
628     *
629     * TclInitSubsystems --
630     *
631     *      Initialize various subsytems in Tcl.  This should be called the
632     *      first time an interp is created, or before any of the subsystems
633     *      are used.  This function ensures an order for the initialization
634     *      of subsystems:
635     *
636     *      1. that cannot be initialized in lazy order because they are
637     *      mutually dependent.
638     *
639     *      2. so that they can be finalized in a known order w/o causing
640     *      the subsequent re-initialization of a subsystem in the act of
641     *      shutting down another.
642     *
643     * Results:
644     *      None.
645     *
646     * Side effects:
647     *      Varied, see the respective initialization routines.
648     *
649     *-------------------------------------------------------------------------
650     */
651    
652    void
653    TclInitSubsystems(argv0)
654        CONST char *argv0;          /* Name of executable from argv[0] to main()
655                                     * in native multi-byte encoding. */
656    {
657        ThreadSpecificData *tsdPtr;
658    
659        if (inFinalize != 0) {
660            panic("TclInitSubsystems called while finalizing");
661        }
662    
663        /*
664         * Grab the thread local storage pointer before doing anything because
665         * the initialization routines will be registering exit handlers.
666         * We use this pointer to detect if this is the first time this
667         * thread has created an interpreter.
668         */
669    
670        tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
671    
672        if (subsystemsInitialized == 0) {
673            /*
674             * Double check inside the mutex.  There are definitly calls
675             * back into this routine from some of the procedures below.
676             */
677    
678            TclpInitLock();
679            if (subsystemsInitialized == 0) {
680                /*
681                 * Have to set this bit here to avoid deadlock with the
682                 * routines below us that call into TclInitSubsystems.
683                 */
684    
685                subsystemsInitialized = 1;
686    
687                tclExecutableName = NULL;
688    
689                /*
690                 * Initialize locks used by the memory allocators before anything
691                 * interesting happens so we can use the allocators in the
692                 * implementation of self-initializing locks.
693                 */
694    #if USE_TCLALLOC
695                TclInitAlloc(); /* process wide mutex init */
696    #endif
697    #ifdef TCL_MEM_DEBUG
698                TclInitDbCkalloc(); /* process wide mutex init */
699    #endif
700    
701                TclpInitPlatform(); /* creates signal handler(s) */
702                TclInitObjSubsystem(); /* register obj types, create mutexes */
703                TclInitIOSubsystem(); /* inits a tsd key (noop) */
704                TclInitEncodingSubsystem(); /* process wide encoding init */
705                TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */
706            }
707            TclpInitUnlock();
708        }
709    
710        if (tsdPtr == NULL) {
711            /*
712             * First time this thread has created an interpreter.
713             * We fetch the key again just in case no exit handlers were
714             * registered by this point.
715             */
716    
717            (void) TCL_TSD_INIT(&dataKey);
718            TclInitNotifier();
719         }
720    }
721    
722    /*
723     *----------------------------------------------------------------------
724     *
725     * Tcl_Finalize --
726     *
727     *      Shut down Tcl.  First calls registered exit handlers, then
728     *      carefully shuts down various subsystems.
729     *      Called by Tcl_Exit or when the Tcl shared library is being
730     *      unloaded.
731     *
732     * Results:
733     *      None.
734     *
735     * Side effects:
736     *      Varied, see the respective finalization routines.
737     *
738     *----------------------------------------------------------------------
739     */
740    
741    void
742    Tcl_Finalize()
743    {
744        ExitHandler *exitPtr;
745        ThreadSpecificData *tsdPtr;
746    
747        TclpInitLock();
748        tsdPtr = TCL_TSD_INIT(&dataKey);
749        if (subsystemsInitialized != 0) {
750            subsystemsInitialized = 0;
751    
752            /*
753             * Invoke exit handlers first.
754             */
755    
756            Tcl_MutexLock(&exitMutex);
757            inFinalize = 1;
758            for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
759                /*
760                 * Be careful to remove the handler from the list before
761                 * invoking its callback.  This protects us against
762                 * double-freeing if the callback should call
763                 * Tcl_DeleteExitHandler on itself.
764                 */
765    
766                firstExitPtr = exitPtr->nextPtr;
767                Tcl_MutexUnlock(&exitMutex);
768                (*exitPtr->proc)(exitPtr->clientData);
769                ckfree((char *) exitPtr);
770                Tcl_MutexLock(&exitMutex);
771            }    
772            firstExitPtr = NULL;
773            Tcl_MutexUnlock(&exitMutex);
774    
775            /*
776             * Clean up the library path now, before we invalidate thread-local
777             * storage.
778             */
779            if (tsdPtr->tclLibraryPath != NULL) {
780                Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
781                tsdPtr->tclLibraryPath = NULL;
782            }
783    
784            /*
785             * Clean up after the current thread now, after exit handlers.
786             * In particular, the testexithandler command sets up something
787             * that writes to standard output, which gets closed.
788             * Note that there is no thread-local storage after this call.
789             */
790    
791            Tcl_FinalizeThread();
792    
793            /*
794             * Now finalize the Tcl execution environment.  Note that this
795             * must be done after the exit handlers, because there are
796             * order dependencies.
797             */
798    
799            TclFinalizeCompExecEnv();
800            TclFinalizeEnvironment();
801    
802            TclFinalizeEncodingSubsystem();
803    
804            if (tclExecutableName != NULL) {
805                ckfree(tclExecutableName);
806                tclExecutableName = NULL;
807            }
808            if (tclNativeExecutableName != NULL) {
809                ckfree(tclNativeExecutableName);
810                tclNativeExecutableName = NULL;
811            }
812            if (tclDefaultEncodingDir != NULL) {
813                ckfree(tclDefaultEncodingDir);
814                tclDefaultEncodingDir = NULL;
815            }
816            
817            Tcl_SetPanicProc(NULL);
818    
819            /*
820             * Free synchronization objects.  There really should only be one
821             * thread alive at this moment.
822             */
823    
824            TclFinalizeSynchronization();
825    
826            /*
827             * We defer unloading of packages until very late
828             * to avoid memory access issues.  Both exit callbacks and
829             * synchronization variables may be stored in packages.
830             */
831    
832            TclFinalizeLoad();
833    
834            /*
835             * There shouldn't be any malloc'ed memory after this.
836             */
837    
838            TclFinalizeMemorySubsystem();
839            inFinalize = 0;
840        }
841        TclpInitUnlock();
842    }
843    
844    /*
845     *----------------------------------------------------------------------
846     *
847     * Tcl_FinalizeThread --
848     *
849     *      Runs the exit handlers to allow Tcl to clean up its state
850     *      about a particular thread.
851     *
852     * Results:
853     *      None.
854     *
855     * Side effects:
856     *      Varied, see the respective finalization routines.
857     *
858     *----------------------------------------------------------------------
859     */
860    
861    void
862    Tcl_FinalizeThread()
863    {
864        ExitHandler *exitPtr;
865        ThreadSpecificData *tsdPtr =
866                (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
867    
868        if (tsdPtr != NULL) {
869            /*
870             * Invoke thread exit handlers first.
871             */
872    
873            tsdPtr->inExit = 1;
874            for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
875                    exitPtr = tsdPtr->firstExitPtr) {
876                /*
877                 * Be careful to remove the handler from the list before invoking
878                 * its callback.  This protects us against double-freeing if the
879                 * callback should call Tcl_DeleteThreadExitHandler on itself.
880                 */
881    
882                tsdPtr->firstExitPtr = exitPtr->nextPtr;
883                (*exitPtr->proc)(exitPtr->clientData);
884                ckfree((char *) exitPtr);
885            }
886            TclFinalizeIOSubsystem();
887            TclFinalizeNotifier();
888    
889            /*
890             * Blow away all thread local storage blocks.
891             */
892    
893            TclFinalizeThreadData();
894        }
895    }
896    
897    /*
898     *----------------------------------------------------------------------
899     *
900     * TclInExit --
901     *
902     *      Determines if we are in the middle of exit-time cleanup.
903     *
904     * Results:
905     *      If we are in the middle of exiting, 1, otherwise 0.
906     *
907     * Side effects:
908     *      None.
909     *
910     *----------------------------------------------------------------------
911     */
912    
913    int
914    TclInExit()
915    {
916        ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
917        return tsdPtr->inExit;
918    }
919    
920    /*
921     *----------------------------------------------------------------------
922     *
923     * Tcl_VwaitObjCmd --
924     *
925     *      This procedure is invoked to process the "vwait" Tcl command.
926     *      See the user documentation for details on what it does.
927     *
928     * Results:
929     *      A standard Tcl result.
930     *
931     * Side effects:
932     *      See the user documentation.
933     *
934     *----------------------------------------------------------------------
935     */
936    
937            /* ARGSUSED */
938    int
939    Tcl_VwaitObjCmd(clientData, interp, objc, objv)
940        ClientData clientData;      /* Not used. */
941        Tcl_Interp *interp;         /* Current interpreter. */
942        int objc;                   /* Number of arguments. */
943        Tcl_Obj *CONST objv[];      /* Argument objects. */
944    {
945        int done, foundEvent;
946        char *nameString;
947    
948        if (objc != 2) {
949            Tcl_WrongNumArgs(interp, 1, objv, "name");
950            return TCL_ERROR;
951        }
952        nameString = Tcl_GetString(objv[1]);
953        if (Tcl_TraceVar(interp, nameString,
954                TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
955                VwaitVarProc, (ClientData) &done) != TCL_OK) {
956            return TCL_ERROR;
957        };
958        done = 0;
959        foundEvent = 1;
960        while (!done && foundEvent) {
961            foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
962        }
963        Tcl_UntraceVar(interp, nameString,
964                TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
965                VwaitVarProc, (ClientData) &done);
966    
967        /*
968         * Clear out the interpreter's result, since it may have been set
969         * by event handlers.
970         */
971    
972        Tcl_ResetResult(interp);
973        if (!foundEvent) {
974            Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
975                    "\":  would wait forever", (char *) NULL);
976            return TCL_ERROR;
977        }
978        return TCL_OK;
979    }
980    
981            /* ARGSUSED */
982    static char *
983    VwaitVarProc(clientData, interp, name1, name2, flags)
984        ClientData clientData;      /* Pointer to integer to set to 1. */
985        Tcl_Interp *interp;         /* Interpreter containing variable. */
986        char *name1;                /* Name of variable. */
987        char *name2;                /* Second part of variable name. */
988        int flags;                  /* Information about what happened. */
989    {
990        int *donePtr = (int *) clientData;
991    
992        *donePtr = 1;
993        return (char *) NULL;
994    }
995    
996    /*
997     *----------------------------------------------------------------------
998     *
999     * Tcl_UpdateObjCmd --
1000     *
1001     *      This procedure is invoked to process the "update" Tcl command.
1002     *      See the user documentation for details on what it does.
1003     *
1004     * Results:
1005     *      A standard Tcl result.
1006     *
1007     * Side effects:
1008     *      See the user documentation.
1009     *
1010     *----------------------------------------------------------------------
1011     */
1012    
1013            /* ARGSUSED */
1014    int
1015    Tcl_UpdateObjCmd(clientData, interp, objc, objv)
1016        ClientData clientData;      /* Not used. */
1017        Tcl_Interp *interp;         /* Current interpreter. */
1018        int objc;                   /* Number of arguments. */
1019        Tcl_Obj *CONST objv[];      /* Argument objects. */
1020    {
1021        int optionIndex;
1022        int flags = 0;              /* Initialized to avoid compiler warning. */
1023        static char *updateOptions[] = {"idletasks", (char *) NULL};
1024        enum updateOptions {REGEXP_IDLETASKS};
1025    
1026        if (objc == 1) {
1027            flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
1028        } else if (objc == 2) {
1029            if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
1030                    "option", 0, &optionIndex) != TCL_OK) {
1031                return TCL_ERROR;
1032            }
1033            switch ((enum updateOptions) optionIndex) {
1034                case REGEXP_IDLETASKS: {
1035                    flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
1036                    break;
1037                }
1038                default: {
1039                    panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
1040                }
1041            }
1042        } else {
1043            Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
1044            return TCL_ERROR;
1045        }
1046        
1047        while (Tcl_DoOneEvent(flags) != 0) {
1048            /* Empty loop body */
1049        }
1050    
1051        /*
1052         * Must clear the interpreter's result because event handlers could
1053         * have executed commands.
1054         */
1055    
1056        Tcl_ResetResult(interp);
1057        return TCL_OK;
1058    }
1059    
1060    /* End of tclevent.c */
Legend:
Removed from v.44  
changed lines
  Added in v.98
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25