path: root/generic/tclEvent.c

/* 
 * 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.
 * Copyright (c) 2004 by Zoran Vasiljevic.
 *
 * 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.58 2005/06/22 19:47:42 kennykb Exp $
 */

#include "tclInt.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 an idle handler command
 * can be invoked.
 */

typedef struct BgError {
    Tcl_Obj *errorMsg;		/* Copy of the error message (the interp's
				 * result when the error occurred). */
    Tcl_Obj *returnOpts;	/* Active return options when the
				 * error occurred */
    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 {
    Tcl_Interp *interp;		/* Interpreter in which error occurred. */
    Tcl_Obj *cmdPrefix;		/* First word(s) of the handler command */
    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;

/*
 * This variable contains the application wide exit handler.  It will be
 * called by Tcl_Exit instead of the C-runtime exit if this variable is set
 * to a non-NULL value.
 */

static Tcl_ExitProc *appExitPtr = NULL;

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. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

#ifdef TCL_THREADS

typedef struct {
    Tcl_ThreadCreateProc *proc;	/* Main() function of the thread */
    ClientData clientData;	/* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_((
           ClientData clientData));
#endif

/*
 * 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, CONST char *name1, 
			    CONST 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:
 *	A handler command is invoked later as an idle handler to
 *	process the error, passing it the interp result and return
 *	options.  
 *
 *----------------------------------------------------------------------
 */

void
Tcl_BackgroundError(interp)
    Tcl_Interp *interp;		/* Interpreter in which an error has
				 * occurred. */
{
    BgError *errPtr;
    ErrAssocData *assocPtr;

    errPtr = (BgError *) ckalloc(sizeof(BgError));
    errPtr->errorMsg = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(errPtr->errorMsg);
    errPtr->returnOpts = Tcl_GetReturnOptions(interp, TCL_ERROR);
    Tcl_IncrRefCount(errPtr->returnOpts);
    errPtr->nextPtr = NULL;

    (void) TclGetBgErrorHandler(interp);
    assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
	    (Tcl_InterpDeleteProc **) NULL);
    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 the handler command takes for the errors.
 *
 *----------------------------------------------------------------------
 */

static void
HandleBgErrors(clientData)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
{
    ErrAssocData *assocPtr = (ErrAssocData *) clientData;
    Tcl_Interp *interp = assocPtr->interp;
    BgError *errPtr;

    /*
     * Not bothering to save/restore the interp state.  Assume that
     * any code that has interp state it needs to keep will make
     * its own Tcl_SaveInterpState call before calling something like
     * Tcl_DoOneEvent() that could lead us here.
     */

    Tcl_Preserve((ClientData) assocPtr);
    Tcl_Preserve((ClientData) interp);
    while (assocPtr->firstBgPtr != NULL) {
	int code, prefixObjc;
	Tcl_Obj **prefixObjv, **tempObjv;

	errPtr = assocPtr->firstBgPtr;

	Tcl_IncrRefCount(assocPtr->cmdPrefix);
	Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix,
		&prefixObjc, &prefixObjv);
	tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
	memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
	tempObjv[prefixObjc] = errPtr->errorMsg;
	tempObjv[prefixObjc+1] = errPtr->returnOpts;
	Tcl_AllowExceptions(interp);
	code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);

	/*
	 * Discard the command and the information about the error report.
	 */

	Tcl_DecrRefCount(assocPtr->cmdPrefix);
	Tcl_DecrRefCount(errPtr->errorMsg);
	Tcl_DecrRefCount(errPtr->returnOpts);
	assocPtr->firstBgPtr = errPtr->nextPtr;
	ckfree((char *) errPtr);

	if (code == TCL_BREAK) {
	    /*
	     * Break means cancel any remaining error reports for this
	     * interpreter.
	     */
	    while (assocPtr->firstBgPtr != NULL) {
		errPtr = assocPtr->firstBgPtr;
		assocPtr->firstBgPtr = errPtr->nextPtr;
		Tcl_DecrRefCount(errPtr->errorMsg);
		Tcl_DecrRefCount(errPtr->returnOpts);
		ckfree((char *) errPtr);
	    }
	} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
	    Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
		Tcl_Obj *keyPtr = Tcl_NewStringObj("-errorinfo", -1);
		Tcl_Obj *valuePtr;

		Tcl_IncrRefCount(keyPtr);
		Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
		Tcl_DecrRefCount(keyPtr);

		Tcl_WriteChars(errChannel,
			"error in background error handler:\n", -1);
		if (valuePtr) {
		    Tcl_WriteObj(errChannel, valuePtr);
		} else {
		    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		}
		Tcl_WriteChars(errChannel, "\n", 1);
                Tcl_Flush(errChannel);
	    }
	}
    }
    assocPtr->lastBgPtr = NULL;
    Tcl_Release((ClientData) interp);
    Tcl_Release((ClientData) assocPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclDefaultBgErrorHandlerObjCmd --
 *
 *	This procedure is invoked to process the "::tcl::Bgerror" Tcl
 *	command.  It is the default handler command registered with
 *	[interp bgerror] for the sake of compatibility with older Tcl
 *	releases.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	Depends on what actions the "bgerror" command takes for the errors.
 *
 *----------------------------------------------------------------------
 */

int
TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_Obj *keyPtr, *valuePtr;
    Tcl_Obj *tempObjv[2];
    int code;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "msg options");
	return TCL_ERROR;
    }

    /*
     * Restore important state variables to what they were at
     * the time the error occurred.
     *
     * Need to set the variables, not the interp fields, because
     * Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy
     * anything we write to the interp fields.
     */

    keyPtr = Tcl_NewStringObj("-errorcode", -1);
    Tcl_IncrRefCount(keyPtr);
    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (valuePtr) {
	Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY);
    }

    keyPtr = Tcl_NewStringObj("-errorinfo", -1);
    Tcl_IncrRefCount(keyPtr);
    Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
    Tcl_DecrRefCount(keyPtr);
    if (valuePtr) {
	Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY);
    }

    /* Create and invoke the bgerror command. */

    tempObjv[0] = Tcl_NewStringObj("bgerror", -1);
    Tcl_IncrRefCount(tempObjv[0]);
    tempObjv[1] = objv[1];
    Tcl_AllowExceptions(interp);
    code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
    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_ResetResult(interp);
	    TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
	} else {
	    Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

		Tcl_IncrRefCount(resultPtr);
		if (Tcl_FindCommand(interp, "bgerror",
			    NULL, TCL_GLOBAL_ONLY) == NULL) {
		    if (valuePtr) {
			Tcl_WriteObj(errChannel, valuePtr);
			Tcl_WriteChars(errChannel, "\n", -1);
		    }
                } else {
		    Tcl_WriteChars(errChannel,
			    "bgerror failed to handle background error.\n", -1);
		    Tcl_WriteChars(errChannel, "    Original error: ", -1);
		    Tcl_WriteObj(errChannel, objv[1]);
		    Tcl_WriteChars(errChannel, "\n", -1);
		    Tcl_WriteChars(errChannel,
				"    Error in bgerror: ", -1);
		    Tcl_WriteObj(errChannel, resultPtr);
		    Tcl_WriteChars(errChannel, "\n", -1);
                }
		Tcl_DecrRefCount(resultPtr);
                Tcl_Flush(errChannel);
	    }
	}
	code = TCL_OK;
    }
    Tcl_DecrRefCount(tempObjv[0]);
    Tcl_ResetResult(interp);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetBgErrorHandler --
 *
 *	This procedure sets the command prefix to be used to handle
 *	background errors in interp.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Error handler is registered.
 *
 *----------------------------------------------------------------------
 */

void
TclSetBgErrorHandler(interp, cmdPrefix)
    Tcl_Interp *interp;
    Tcl_Obj *cmdPrefix;
{
    ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
	    "tclBgError", (Tcl_InterpDeleteProc **) NULL);

    if (cmdPrefix == NULL) {
	Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
    }
    if (assocPtr == NULL) {
	/* First access: initialize */
	assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
	assocPtr->interp = interp;
	assocPtr->cmdPrefix = NULL;
	assocPtr->firstBgPtr = NULL;
	assocPtr->lastBgPtr = NULL;
	Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
		(ClientData) assocPtr);
    }
    if (assocPtr->cmdPrefix) {
	Tcl_DecrRefCount(assocPtr->cmdPrefix);
    }
    assocPtr->cmdPrefix = cmdPrefix;
    Tcl_IncrRefCount(assocPtr->cmdPrefix);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetBgErrorHandler --
 *
 *	This procedure retrieves the command prefix currently used
 *	to handle background errors in interp.
 *
 * Results:
 *	A (Tcl_Obj *) to a list of words (command prefix).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclGetBgErrorHandler(interp)
    Tcl_Interp *interp;
{
    ErrAssocData *assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
	    "tclBgError", (Tcl_InterpDeleteProc **) NULL);

    if (assocPtr == NULL) {
	TclSetBgErrorHandler(interp, Tcl_NewStringObj("::tcl::Bgerror", -1));
	assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp,
	    "tclBgError", (Tcl_InterpDeleteProc **) NULL);
    }
    return assocPtr->cmdPrefix;
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
	Tcl_DecrRefCount(errPtr->errorMsg);
	Tcl_DecrRefCount(errPtr->returnOpts);
	ckfree((char *) errPtr);
    }
    Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
    Tcl_DecrRefCount(assocPtr->cmdPrefix);
    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_SetExitProc --
 *
 *	This procedure sets the application wide exit handler that
 *	will be called by Tcl_Exit in place of the C-runtime exit.  If
 *	the application wide exit handler is NULL, the C-runtime exit
 *	will be used instead.
 *
 * Results:
 *	The previously set application wide exit handler.
 *
 * Side effects:
 *	Sets the application wide exit handler to the specified value.
 *
 *----------------------------------------------------------------------
 */

Tcl_ExitProc *
Tcl_SetExitProc(proc)
    Tcl_ExitProc *proc; /* new exit handler for app or NULL */
{
    Tcl_ExitProc *prevExitProc;

    /*
     * Swap the old exit proc for the new one, saving the old one for
     * our return value.
     */

    Tcl_MutexLock(&exitMutex);
    prevExitProc = appExitPtr;
    appExitPtr = proc;
    Tcl_MutexUnlock(&exitMutex);

    return prevExitProc;
}

/*
 *----------------------------------------------------------------------
 *
 * 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_ExitProc *currentAppExitPtr;

    Tcl_MutexLock(&exitMutex);
    currentAppExitPtr = appExitPtr;
    Tcl_MutexUnlock(&exitMutex);

    if (currentAppExitPtr) {
	/*
	 * Warning: this code SHOULD NOT return, as there is code that
	 * depends on Tcl_Exit never returning.  In fact, we will
	 * Tcl_Panic if anyone returns, so critical is this dependcy.
	 */
	currentAppExitPtr((ClientData) status);
	Tcl_Panic("AppExitProc returned unexpectedly");
    } else {
	/* use default handling */
	Tcl_Finalize();
	TclpExit(status);
	Tcl_Panic("OS exit failed!");
    }
}

/*
 *-------------------------------------------------------------------------
 *
 * 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()
{
    if (inFinalize != 0) {
	Tcl_Panic("TclInitSubsystems called while finalizing");
    }

    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;

	    /*
	     * 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) */
	    TclInitDoubleConversion(); /* initializes constants for
					* converting to/from double */
    	    TclInitObjSubsystem(); /* register obj types, create mutexes */
	    TclInitIOSubsystem(); /* inits a tsd key (noop) */
	    TclInitEncodingSubsystem(); /* process wide encoding init */
	    TclpSetInterfaces();
    	    TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */
	}
	TclpInitUnlock();
    }
    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;
    
    /*
     * 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);

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

	/*
	 * Ensure the thread-specific data is initialised as it is
	 * used in Tcl_FinalizeThread()
	 */

	(void) TCL_TSD_INIT(&dataKey);

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

	Tcl_SetPanicProc(NULL);

	/*
	 * Repeat finalization of the thread local storage once more.
	 * Although this step is already done by the Tcl_FinalizeThread
	 * call above, series of events happening afterwards may
	 * re-initialize TSD slots.  Those need to be finalized again,
	 * otherwise we're leaking memory chunks.
	 * Very important to note is that things happening afterwards
	 * should not reference anything which may re-initialize TSD's.
	 * This includes freeing Tcl_Objs's, among other things.
	 *
	 * This fixes the Tcl Bug #990552.
	 */
	TclFinalizeThreadData();

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

	/* Now we can free constants for conversions to/from double */

	TclFinalizeDoubleConversion();
	
	/*
	 * There have been several bugs in the past that cause
	 * exit handlers to be established during Tcl_Finalize
	 * processing.  Such exit handlers leave malloc'ed memory,
	 * and Tcl_FinalizeThreadAlloc or Tcl_FinalizeMemorySubsystem
	 * will result in a corrupted heap.  The result can be a
	 * mysterious crash on process exit.  Check here that
	 * nobody's done this.
	 */

	if ( firstExitPtr != NULL ) {
	    Tcl_Panic( "exit handlers were created during Tcl_Finalize" );
	}

	/*
	 * There shouldn't be any malloc'ed memory after this.
	 */
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
	TclFinalizeThreadAlloc();
#endif
	TclFinalizeMemorySubsystem();
	inFinalize = 0;
    }
    TclFinalizeLock();
}

/*
 *----------------------------------------------------------------------
 *
 * 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;

	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);
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "limit exceeded", NULL);
	    return TCL_ERROR;
	}
    }
    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: {
		Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
	    }
	}
    } else {
        Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
	return TCL_ERROR;
    }
    
    while (Tcl_DoOneEvent(flags) != 0) {
	if (Tcl_LimitExceeded(interp)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "limit exceeded", NULL);
	    return TCL_ERROR;
	}
    }

    /*
     * Must clear the interpreter's result because event handlers could
     * have executed commands.
     */

    Tcl_ResetResult(interp);
    return TCL_OK;
}

#ifdef TCL_THREADS
/*
 *-----------------------------------------------------------------------------
 *
 *  NewThreadProc --
 *
 * 	Bootstrap function of a new Tcl thread.
 *
 * Results:
 *	None.
 *
 * Side Effects:
 *	Initializes Tcl notifier for the current thread.
 *
 *-----------------------------------------------------------------------------
 */

static Tcl_ThreadCreateType
NewThreadProc(ClientData clientData)
{
    ThreadClientData *cdPtr;
    ClientData threadClientData;
    Tcl_ThreadCreateProc *threadProc;

    cdPtr  = (ThreadClientData *)clientData;
    threadProc = cdPtr->proc;
    threadClientData = cdPtr->clientData;
    Tcl_Free((char*)clientData); /* Allocated in Tcl_CreateThread() */

    (*threadProc)(threadClientData);

    TCL_THREAD_CREATE_RETURN;
}
#endif
/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateThread --
 *
 *	This procedure creates a new thread. This actually belongs
 *	to the tclThread.c file but since we use some private 
 *	data structures local to this file, it is placed here.
 *
 * Results:
 *	TCL_OK if the thread could be created.  The thread ID is
 *	returned in a parameter.
 *
 * Side effects:
 *	A new thread is created.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags)
    Tcl_ThreadId *idPtr;		/* Return, the ID of the thread */
    Tcl_ThreadCreateProc proc;		/* Main() function of the thread */
    ClientData clientData;		/* The one argument to Main() */
    int stackSize;			/* Size of stack for the new thread */
    int flags;				/* Flags controlling behaviour of
					 * the new thread */
{
#ifdef TCL_THREADS
    ThreadClientData *cdPtr;

    cdPtr = (ThreadClientData*)Tcl_Alloc(sizeof(ThreadClientData));
    cdPtr->proc = proc;
    cdPtr->clientData = clientData;

    return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr,
                           stackSize, flags);
#else
    return TCL_ERROR;
#endif /* TCL_THREADS */
}