/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclevent.c

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

Parent Directory | Revision Log | View Patch Patch

-revision 64 by dashley,
Sun Oct 30 04:21:11 2016 UTC
+revision 71 by dashley,
Sat Nov  5 11:07:06 2016 UTC
 Line 1
  /* $Header$ */
  /*
   * 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;
  }
  /* End of tclevent.c */

 Legend:



Removed from v.64
 


changed lines


 
Added in v.71
 Legend:



Removed from v.64
 


changed lines


 
Added in v.71
-Removed from v.64
+Added in v.71

dashley@gmail.com	ViewVC Help
Powered by ViewVC 1.1.25