tclevent.c

tcl是工具命令语言

 *----------------------------------------------------------------------
 */

void
Tcl_Finalize()
{
    ExitHandler *exitPtr;
    ThreadSpecificData *tsdPtr;

    TclpInitLock();
    if (subsystemsInitialized != 0) {
	subsystemsInitialized = 0;

	tsdPtr = TCL_TSD_INIT(&dataKey);

	/*
	 * 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 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();

	/* 
	 * Finalizing the filesystem must come after anything which
	 * might conceivably interact with the 'Tcl_FS' API. 
	 */
	TclFinalizeFilesystem();

	/* 
	 * We must be sure the encoding finalization doesn't need
	 * to examine the filesystem in any way.  Since it only
	 * needs to clean up internal data structures, this is
	 * fine.
	 */
	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.
	 * 
	 * Note that TclFinalizeLoad unloads packages in the reverse
	 * of the order they were loaded in (i.e. last to be loaded
	 * is the first to be unloaded).  This can be important for
	 * correct unloading when dependencies exist.
	 * 
	 * Once load has been finalized, we will have deleted any
	 * temporary copies of shared libraries and can therefore
	 * reset the filesystem to its original state.
	 */

	TclFinalizeLoad();
	TclResetFilesystem();
	
	/*
	 * 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) {
	tsdPtr->inExit = 1;

	/*
	 * Clean up the library path now, before we invalidate thread-local
	 * storage or calling thread exit handlers.
	 */

	if (tsdPtr->tclLibraryPath != NULL) {
	    Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
	    tsdPtr->tclLibraryPath = NULL;
	}

	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();
	TclFinalizeAsync();
    }

	/*
	 * Blow away all thread local storage blocks.
     *
     * Note that Tcl API allows creation of threads which do not use any
     * Tcl interp or other Tcl subsytems. Those threads might, however,
     * use thread local storage, so we must unconditionally finalize it.
     *
     * Fix [Bug #571002]
	 */

	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()
{
    return inFinalize;
}

/*
 *----------------------------------------------------------------------
 *
 * TclInThreadExit --
 *
 *	Determines if we are in the middle of thread exit-time cleanup.
 *
 * Results:
 *	If we are in the middle of exiting this thread, 1, otherwise 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclInThreadExit()
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
	    TclThreadDataKeyGet(&dataKey);
    if (tsdPtr == NULL) {
	return 0;
    } else {
	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. */
    CONST char *name1;		/* Name of variable. */
    CONST 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 CONST 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;
}