/* 

 * 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.

 * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.  

 * 

 * 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.28.2.15 2007/03/19 17:06:25 dgp Exp $

 */

#include "tclInt.h"

#include "tclPort.h"

#if defined(__SYMBIAN32__) && defined(__WINSCW__)

#include "tclSymbianGlobals.h"

#define dataKey getdataKey(0)

#endif 

/*

 * 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.

 */

#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)

static int inFinalize = 0;

static int subsystemsInitialized = 0;

#endif

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;

#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)

static Tcl_ThreadDataKey dataKey;

/*

 * Common string for the library path for sharing across threads.

 * This is ckalloc'd and cleared in Tcl_Finalize.

 */

static char *tclLibraryPathStr = NULL;

#endif

#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:

 *	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.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C void

Tcl_BackgroundError(interp)

    Tcl_Interp *interp;		/* Interpreter in which an error has

				 * occurred. */

{

    BgError *errPtr;

    CONST 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;

    CONST 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 (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) {

                    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.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C 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.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C 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.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C 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.