/* 

 * tclThreadTest.c --

 *

 *	This file implements the testthread command.  Eventually this

 *	should be tclThreadCmd.c

 *	Some of this code is based on work done by Richard Hipp on behalf of

 *	Conservation Through Innovation, Limited, with their permission.

 *

 * Copyright (c) 1998 by 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: tclThreadTest.c,v 1.16.2.2 2006/09/22 14:48:52 dkf Exp $

 */

#include "tclInt.h"

#ifdef TCL_THREADS

/*

 * Each thread has an single instance of the following structure.  There

 * is one instance of this structure per thread even if that thread contains

 * multiple interpreters.  The interpreter identified by this structure is

 * the main interpreter for the thread.  

 *

 * The main interpreter is the one that will process any messages 

 * received by a thread.  Any thread can send messages but only the

 * main interpreter can receive them.

 */

typedef struct ThreadSpecificData {

    Tcl_ThreadId  threadId;          /* Tcl ID for this thread */

    Tcl_Interp *interp;              /* Main interpreter for this thread */

    int flags;                       /* See the TP_ defines below... */

    struct ThreadSpecificData *nextPtr;	/* List for "thread names" */

    struct ThreadSpecificData *prevPtr;	/* List for "thread names" */

} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*

 * This list is used to list all threads that have interpreters.

 * This is protected by threadMutex.

 */

static struct ThreadSpecificData *threadList;

/*

 * The following bit-values are legal for the "flags" field of the

 * ThreadSpecificData structure.

 */

#define TP_Dying               0x001 /* This thread is being cancelled */

/*

 * An instance of the following structure contains all information that is

 * passed into a new thread when the thread is created using either the

 * "thread create" Tcl command or the TclCreateThread() C function.

 */

typedef struct ThreadCtrl {

    char *script;    /* The TCL command this thread should execute */

    int flags;        /* Initial value of the "flags" field in the 

                       * ThreadSpecificData structure for the new thread.

                       * Might contain TP_Detached or TP_TclThread. */

    Tcl_Condition condWait;

    /* This condition variable is used to synchronize

     * the parent and child threads.  The child won't run

     * until it acquires threadMutex, and the parent function

     * won't complete until signaled on this condition

     * variable. */

} ThreadCtrl;

/*

 * This is the event used to send scripts to other threads.

 */

typedef struct ThreadEvent {

    Tcl_Event event;		/* Must be first */

    char *script;		/* The script to execute. */

    struct ThreadEventResult *resultPtr;

				/* To communicate the result.  This is

				 * NULL if we don't care about it. */

} ThreadEvent;

typedef struct ThreadEventResult {

    Tcl_Condition done;		/* Signaled when the script completes */

    int code;			/* Return value of Tcl_Eval */

    char *result;		/* Result from the script */

    char *errorInfo;		/* Copy of errorInfo variable */

    char *errorCode;		/* Copy of errorCode variable */

    Tcl_ThreadId srcThreadId;	/* Id of sending thread, in case it dies */

    Tcl_ThreadId dstThreadId;	/* Id of target thread, in case it dies */

    struct ThreadEvent *eventPtr;	/* Back pointer */

    struct ThreadEventResult *nextPtr;	/* List for cleanup */

    struct ThreadEventResult *prevPtr;

} ThreadEventResult;

static ThreadEventResult *resultList;

/*

 * This is for simple error handling when a thread script exits badly.

 */

static Tcl_ThreadId errorThreadId;

static char *errorProcString;

/* 

 * Access to the list of threads and to the thread send results is

 * guarded by this mutex. 

 */

TCL_DECLARE_MUTEX(threadMutex)

#undef TCL_STORAGE_CLASS

#define TCL_STORAGE_CLASS DLLEXPORT

EXTERN int	TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));

EXTERN int	Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData,

	Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

EXTERN int	TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp,

	char *script, int joinable));

EXTERN int	TclThreadList _ANSI_ARGS_((Tcl_Interp *interp));

EXTERN int	TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id,

	char *script, int wait));

#undef TCL_STORAGE_CLASS

#define TCL_STORAGE_CLASS DLLIMPORT

Tcl_ThreadCreateType	NewTestThread _ANSI_ARGS_((ClientData clientData));

static void	ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));

static void	ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));

static int	ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));

static void	ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));

static void	ThreadFreeProc _ANSI_ARGS_((ClientData clientData));

static int	ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,

	ClientData clientData));

static void	ThreadExitProc _ANSI_ARGS_((ClientData clientData));

/*

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

 *

 * TclThread_Init --

 *

 *	Initialize the test thread command.

 *

 * Results:

 *      TCL_OK if the package was properly initialized.

 *

 * Side effects:

 *	Add the "testthread" command to the interp.

 *

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

 */

int

TclThread_Init(interp)

    Tcl_Interp *interp; /* The current Tcl interpreter */

{

    Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, 

	    (ClientData)NULL ,NULL);

    if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) {

	return TCL_ERROR;

    }

    return TCL_OK;

}

/*

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

 *

 * Tcl_ThreadObjCmd --

 *

 *	This procedure is invoked to process the "testthread" Tcl command.

 *	See the user documentation for details on what it does.

 *

 *	thread create ?-joinable? ?script?

 *	thread send id ?-async? script

 *	thread exit

 *	thread info id

 *	thread names

 *	thread wait

 *	thread errorproc proc

 *	thread join id

 *

 * Results:

 *	A standard Tcl result.

 *

 * Side effects:

 *	See the user documentation.

 *

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

 */

	/* ARGSUSED */

int

Tcl_ThreadObjCmd(dummy, interp, objc, objv)

    ClientData dummy;			/* Not used. */

    Tcl_Interp *interp;			/* Current interpreter. */

    int objc;				/* Number of arguments. */

    Tcl_Obj *CONST objv[];		/* Argument objects. */

{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    int option;

    static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names",

				    "send", "wait", "errorproc",

				    (char *) NULL};

    enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN,

		  THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};

    if (objc < 2) {

	Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");

	return TCL_ERROR;

    }

    if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions,

	    "option", 0, &option) != TCL_OK) {

	return TCL_ERROR;

    }

    /* 

     * Make sure the initial thread is on the list before doing anything.

     */

    if (tsdPtr->interp == NULL) {

	Tcl_MutexLock(&threadMutex);

	tsdPtr->interp = interp;

	ListUpdateInner(tsdPtr);

	Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);

	Tcl_MutexUnlock(&threadMutex);

    }

    switch ((enum options)option) {

	case THREAD_CREATE: {

	    char *script;

	    int   joinable, len;

	    if (objc == 2) {

	        /* Neither joinable nor special script

		 */

	        joinable = 0;

		script   = "testthread wait";	/* Just enter the event loop */

	    } else if (objc == 3) {

	        /* Possibly -joinable, then no special script,

		 * no joinable, then its a script.

		 */

	        script = Tcl_GetString(objv[2]);

		len    = strlen (script);

		if ((len > 1) &&

		    (script [0] == '-') && (script [1] == 'j') &&

		    (0 == strncmp (script, "-joinable", (size_t) len))) {

		    joinable = 1;

		    script   = "testthread wait"; /* Just enter the event loop

						   */

		} else {

		    /* Remember the script */

		    joinable = 0;

		}

	    } else if (objc == 4) {

	        /* Definitely a script available, but is the flag

		 * -joinable ?

		 */

	        script = Tcl_GetString(objv[2]);

		len    = strlen (script);

		joinable = ((len > 1) &&

			    (script [0] == '-') && (script [1] == 'j') &&

			    (0 == strncmp (script, "-joinable", (size_t) len)));

		script = Tcl_GetString(objv[3]);

	    } else {

		Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");

		return TCL_ERROR;

	    }

	    return TclCreateThread(interp, script, joinable);

	}

	case THREAD_EXIT: {

	    if (objc > 2) {

		Tcl_WrongNumArgs(interp, 1, objv, NULL);

		return TCL_ERROR;

	    }

	    ListRemove(NULL);

	    Tcl_ExitThread(0);

	    return TCL_OK;

	}

	case THREAD_ID:

	    if (objc == 2) {

		Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());

		Tcl_SetObjResult(interp, idObj);

		return TCL_OK;

	    } else {

		Tcl_WrongNumArgs(interp, 2, objv, NULL);

		return TCL_ERROR;

	    }

        case THREAD_JOIN: {

	    long id;

	    int result, status;

	    if (objc != 3) {

		Tcl_WrongNumArgs(interp, 1, objv, "join id");

		return TCL_ERROR;

	    }

	    if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {

		return TCL_ERROR;

	    }

	    result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);

	    if (result == TCL_OK) {

	        Tcl_SetIntObj (Tcl_GetObjResult (interp), status);

	    } else {

	        char buf [20];

		sprintf (buf, "%ld", id);

		Tcl_AppendResult (interp, "cannot join thread ", buf, NULL);

	    }

	    return result;

	}

	case THREAD_NAMES: {

	    if (objc > 2) {

		Tcl_WrongNumArgs(interp, 2, objv, NULL);

		return TCL_ERROR;

	    }

	    return TclThreadList(interp);

	}

	case THREAD_SEND: {

	    long id;

	    char *script;

	    int wait, arg;

	    if ((objc != 4) && (objc != 5)) {

		Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");

		return TCL_ERROR;

	    }

	    if (objc == 5) {

		if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {

		    Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");

		    return TCL_ERROR;

		}

		wait = 0;

		arg = 3;

	    } else {

		wait = 1;

		arg = 2;

	    }

	    if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {

		return TCL_ERROR;

	    }

	    arg++;

	    script = Tcl_GetString(objv[arg]);

	    return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);

	}

	case THREAD_WAIT: {

	    while (1) {

		(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);

	    }

	}

	case THREAD_ERRORPROC: {

	    /*

	     * Arrange for this proc to handle thread death errors.

	     */

	    char *proc;

	    if (objc != 3) {

		Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc");

		return TCL_ERROR;

	    }

	    Tcl_MutexLock(&threadMutex);

	    errorThreadId = Tcl_GetCurrentThread();

	    if (errorProcString) {

		ckfree(errorProcString);

	    }

	    proc = Tcl_GetString(objv[2]);

	    errorProcString = ckalloc(strlen(proc)+1);

	    strcpy(errorProcString, proc);

	    Tcl_MutexUnlock(&threadMutex);

	    return TCL_OK;

	}

    }

    return TCL_OK;

}

/*

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

 *

 * TclCreateThread --

 *

 *	This procedure is invoked to create a thread containing an interp to

 *	run a script.  This returns after the thread has started executing.

 *

 * Results:

 *	A standard Tcl result, which is the thread ID.

 *

 * Side effects:

 *	Create a thread.

 *

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

 */

	/* ARGSUSED */

int

TclCreateThread(interp, script, joinable)

    Tcl_Interp *interp;			/* Current interpreter. */

    char *script;			/* Script to execute */

    int         joinable;		/* Flag, joinable thread or not */

{

    ThreadCtrl ctrl;

    Tcl_ThreadId id;

    ctrl.script = script;

    ctrl.condWait = NULL;

    ctrl.flags = 0;

    joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;

    Tcl_MutexLock(&threadMutex);

    if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,

		 TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {

	Tcl_MutexUnlock(&threadMutex);

        Tcl_AppendResult(interp,"can't create a new thread",NULL);

	ckfree((void*)ctrl.script);

	return TCL_ERROR;

    }

    /*

     * Wait for the thread to start because it is using something on our stack!

     */

    Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);

    Tcl_MutexUnlock(&threadMutex);

    Tcl_ConditionFinalize(&ctrl.condWait);

    Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));

    return TCL_OK;

}

/*

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

 *

 * NewTestThread --

 *

 *    This routine is the "main()" for a new thread whose task is to

 *    execute a single TCL script.  The argument to this function is

 *    a pointer to a structure that contains the text of the TCL script

 *    to be executed.

 *

 *    Space to hold the script field of the ThreadControl structure passed 

 *    in as the only argument was obtained from malloc() and must be freed 

 *    by this function before it exits.  Space to hold the ThreadControl

 *    structure itself is released by the calling function, and the

 *    two condition variables in the ThreadControl structure are destroyed

 *    by the calling function.  The calling function will destroy the

 *    ThreadControl structure and the condition variable as soon as

 *    ctrlPtr->condWait is signaled, so this routine must make copies of

 *    any data it might need after that point.

 *

 * Results:

 *    none

 *

 * Side effects:

 *    A TCL script is executed in a new thread.

 *

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

 */

Tcl_ThreadCreateType

NewTestThread(clientData)

    ClientData clientData;

{

    ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    int result;

    char *threadEvalScript;

    /*

     * Initialize the interpreter.  This should be more general.

     */

    tsdPtr->interp = Tcl_CreateInterp();

    result = Tcl_Init(tsdPtr->interp);

    result = TclThread_Init(tsdPtr->interp);

    /*

     * Update the list of threads.

     */

    Tcl_MutexLock(&threadMutex);

    ListUpdateInner(tsdPtr);

    /*

     * We need to keep a pointer to the alloc'ed mem of the script

     * we are eval'ing, for the case that we exit during evaluation

     */

    threadEvalScript = (char *) ckalloc(strlen(ctrlPtr->script)+1);

    strcpy(threadEvalScript, ctrlPtr->script);

    Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);

    /*

     * Notify the parent we are alive.

     */

    Tcl_ConditionNotify(&ctrlPtr->condWait);

    Tcl_MutexUnlock(&threadMutex);

    /*

     * Run the script.

     */

    Tcl_Preserve((ClientData) tsdPtr->interp);

    result = Tcl_Eval(tsdPtr->interp, threadEvalScript);

    if (result != TCL_OK) {

	ThreadErrorProc(tsdPtr->interp);

    }

    /*

     * Clean up.

     */

    ListRemove(tsdPtr);

    Tcl_Release((ClientData) tsdPtr->interp);

    Tcl_DeleteInterp(tsdPtr->interp);

    Tcl_ExitThread(result);

    TCL_THREAD_CREATE_RETURN;

}

/*

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

 *

 * ThreadErrorProc --

 *

 *    Send a message to the thread willing to hear about errors.

 *

 * Results:

 *    none

 *

 * Side effects:

 *    Send an event.

 *

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

 */

static void

ThreadErrorProc(interp)

    Tcl_Interp *interp;		/* Interp that failed */

{

    Tcl_Channel errChannel;

    CONST char *errorInfo, *argv[3];

    char *script;

    char buf[TCL_DOUBLE_SPACE+1];

    sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());

    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);

    if (errorProcString == NULL) {

	errChannel = Tcl_GetStdChannel(TCL_STDERR);

	Tcl_WriteChars(errChannel, "Error from thread ", -1);

	Tcl_WriteChars(errChannel, buf, -1);

	Tcl_WriteChars(errChannel, "\n", 1);

	Tcl_WriteChars(errChannel, errorInfo, -1);

	Tcl_WriteChars(errChannel, "\n", 1);

    } else {

	argv[0] = errorProcString;

	argv[1] = buf;

	argv[2] = errorInfo;

	script = Tcl_Merge(3, argv);

	TclThreadSend(interp, errorThreadId, script, 0);

	ckfree(script);

    }

}

/*

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

 *

 * ListUpdateInner --

 *

 *    Add the thread local storage to the list.  This assumes

 *	the caller has obtained the mutex.

 *

 * Results:

 *    none

 *

 * Side effects:

 *    Add the thread local storage to its list.

 *

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

 */

static void

ListUpdateInner(tsdPtr)

    ThreadSpecificData *tsdPtr;

{

    if (tsdPtr == NULL) {

	tsdPtr = TCL_TSD_INIT(&dataKey);

    }

    tsdPtr->threadId = Tcl_GetCurrentThread();

    tsdPtr->nextPtr = threadList;

    if (threadList) {

	threadList->prevPtr = tsdPtr;

    }

    tsdPtr->prevPtr = NULL;

    threadList = tsdPtr;

}

/*

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

 *

 * ListRemove --

 *

 *    Remove the thread local storage from its list.  This grabs the

 *	mutex to protect the list.

 *

 * Results:

 *    none

 *

 * Side effects:

 *    Remove the thread local storage from its list.

 *

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

 */

static void

ListRemove(tsdPtr)

    ThreadSpecificData *tsdPtr;

{

    if (tsdPtr == NULL) {

	tsdPtr = TCL_TSD_INIT(&dataKey);

    }

    Tcl_MutexLock(&threadMutex);

    if (tsdPtr->prevPtr) {

	tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;

    } else {

	threadList = tsdPtr->nextPtr;

    }

    if (tsdPtr->nextPtr) {

	tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;

    }

    tsdPtr->nextPtr = tsdPtr->prevPtr = 0;

    Tcl_MutexUnlock(&threadMutex);

}

/*

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

 *

 * TclThreadList --

 *

 *    Return a list of threads running Tcl interpreters.

 *

 * Results:

 *    A standard Tcl result.

 *

 * Side effects:

 *    None.

 *

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

 */

int

TclThreadList(interp)

    Tcl_Interp *interp;

{

    ThreadSpecificData *tsdPtr;

    Tcl_Obj *listPtr;

    listPtr = Tcl_NewListObj(0, NULL);

    Tcl_MutexLock(&threadMutex);

    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {

	Tcl_ListObjAppendElement(interp, listPtr,

		Tcl_NewLongObj((long)tsdPtr->threadId));

    }

    Tcl_MutexUnlock(&threadMutex);

    Tcl_SetObjResult(interp, listPtr);

    return TCL_OK;

}

/*

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

 *

 * TclThreadSend --

 *

 *    Send a script to another thread.

 *

 * Results:

 *    A standard Tcl result.

 *

 * Side effects:

 *    None.

 *

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

 */

int

TclThreadSend(interp, id, script, wait)

    Tcl_Interp *interp;		/* The current interpreter. */

    Tcl_ThreadId id;		/* Thread Id of other interpreter. */

    char *script;		/* The script to evaluate. */

    int wait;			/* If 1, we block for the result. */

{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    ThreadEvent *threadEventPtr;

    ThreadEventResult *resultPtr;

    int found, code;

    Tcl_ThreadId threadId = (Tcl_ThreadId) id;

    /* 

     * Verify the thread exists.

     */

    Tcl_MutexLock(&threadMutex);

    found = 0;

    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {

	if (tsdPtr->threadId == threadId) {

	    found = 1;

	    break;

	}

    }

    if (!found) {

	Tcl_MutexUnlock(&threadMutex);

	Tcl_AppendResult(interp, "invalid thread id", NULL);

	return TCL_ERROR;

    }

    /*

     * Short circut sends to ourself.  Ought to do something with -async,

     * like run in an idle handler.

     */

    if (threadId == Tcl_GetCurrentThread()) {

        Tcl_MutexUnlock(&threadMutex);

	return Tcl_GlobalEval(interp, script);

    }

    /* 

     * Create the event for its event queue.

     */

    threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));

    threadEventPtr->script = ckalloc(strlen(script) + 1);

    strcpy(threadEventPtr->script, script);

    if (!wait) {

	resultPtr = threadEventPtr->resultPtr = NULL;

    } else {

	resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));

	threadEventPtr->resultPtr = resultPtr;

	/*

	 * Initialize the result fields.

	 */

	resultPtr->done = NULL;

	resultPtr->code = 0;

	resultPtr->result = NULL;

	resultPtr->errorInfo = NULL;

	resultPtr->errorCode = NULL;

	/* 

	 * Maintain the cleanup list.

	 */

	resultPtr->srcThreadId = Tcl_GetCurrentThread();

	resultPtr->dstThreadId = threadId;

	resultPtr->eventPtr = threadEventPtr;

	resultPtr->nextPtr = resultList;

	if (resultList) {

	    resultList->prevPtr = resultPtr;

	}

	resultPtr->prevPtr = NULL;

	resultList = resultPtr;

    }

    /*

     * Queue the event and poke the other thread's notifier.

     */

    threadEventPtr->event.proc = ThreadEventProc;

    Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr, 

	    TCL_QUEUE_TAIL);

    Tcl_ThreadAlert(threadId);

    if (!wait) {

	Tcl_MutexUnlock(&threadMutex);

	return TCL_OK;

    }

    /* 

     * Block on the results and then get them.

     */

    Tcl_ResetResult(interp);

    while (resultPtr->result == NULL) {

        Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);

    }

    /*

     * Unlink result from the result list.

     */

    if (resultPtr->prevPtr) {

	resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;

    } else {

	resultList = resultPtr->nextPtr;

    }

    if (resultPtr->nextPtr) {

	resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;

    }

    resultPtr->eventPtr = NULL;

    resultPtr->nextPtr = NULL;

    resultPtr->prevPtr = NULL;

    Tcl_MutexUnlock(&threadMutex);

    if (resultPtr->code != TCL_OK) {

	if (resultPtr->errorCode) {

	    Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);

	    ckfree(resultPtr->errorCode);

	}

	if (resultPtr->errorInfo) {

	    Tcl_AddErrorInfo(interp, resultPtr->errorInfo);

	    ckfree(resultPtr->errorInfo);

	}

    }

    Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);

    Tcl_ConditionFinalize(&resultPtr->done);

    code = resultPtr->code;

    ckfree((char *) resultPtr);

    return code;

}

/*

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

 *

 * ThreadEventProc --

 *

 *    Handle the event in the target thread.

 *

 * Results:

 *    Returns 1 to indicate that the event was processed.

 *

 * Side effects:

 *    Fills out the ThreadEventResult struct.

 *

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

 */

static int

ThreadEventProc(evPtr, mask)

    Tcl_Event *evPtr;		/* Really ThreadEvent */

    int mask;

{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;

    ThreadEventResult *resultPtr = threadEventPtr->resultPtr;

    Tcl_Interp *interp = tsdPtr->interp;

    int code;

    CONST char *result, *errorCode, *errorInfo;

    if (interp == NULL) {

	code = TCL_ERROR;

	result = "no target interp!";

	errorCode = "THREAD";

	errorInfo = "";

    } else {

	Tcl_Preserve((ClientData) interp);

	Tcl_ResetResult(interp);

	Tcl_CreateThreadExitHandler(ThreadFreeProc,

		(ClientData) threadEventPtr->script);

	code = Tcl_GlobalEval(interp, threadEventPtr->script);

	Tcl_DeleteThreadExitHandler(ThreadFreeProc,

		(ClientData) threadEventPtr->script);

	if (code != TCL_OK) {

	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);

	    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);

	} else {

	    errorCode = errorInfo = NULL;

	}

	result = Tcl_GetStringResult(interp);

    }

    ckfree(threadEventPtr->script);

    if (resultPtr) {

	Tcl_MutexLock(&threadMutex);

	resultPtr->code = code;

	resultPtr->result = ckalloc(strlen(result) + 1);

	strcpy(resultPtr->result, result);

	if (errorCode != NULL) {

	    resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);

	    strcpy(resultPtr->errorCode, errorCode);

	}

	if (errorInfo != NULL) {

	    resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);

	    strcpy(resultPtr->errorInfo, errorInfo);

	}

	Tcl_ConditionNotify(&resultPtr->done);

	Tcl_MutexUnlock(&threadMutex);

    }

    if (interp != NULL) {

	Tcl_Release((ClientData) interp);

    }

    return 1;

}

/*

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

 *

 * ThreadFreeProc --

 *

 *    This is called from when we are exiting and memory needs

 *    to be freed.

 *

 * Results:

 *    None.

 *

 * Side effects:

 *	Clears up mem specified in ClientData

 *

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

 */

     /* ARGSUSED */

static void

ThreadFreeProc(clientData)

    ClientData clientData;

{

    if (clientData) {

	ckfree((char *) clientData);

    }

}

/*

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

 *

 * ThreadDeleteEvent --

 *

 *    This is called from the ThreadExitProc to delete memory related

 *    to events that we put on the queue.

 *

 * Results:

 *    1 it was our event and we want it removed, 0 otherwise.

 *

 * Side effects:

 *	It cleans up our events in the event queue for this thread.

 *

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

 */

     /* ARGSUSED */

static int

ThreadDeleteEvent(eventPtr, clientData)

    Tcl_Event *eventPtr;		/* Really ThreadEvent */

    ClientData clientData;		/* dummy */

{

    if (eventPtr->proc == ThreadEventProc) {

	ckfree((char *) ((ThreadEvent *) eventPtr)->script);

	return 1;

    }

    /*

     * If it was NULL, we were in the middle of servicing the event

     * and it should be removed

     */

    return (eventPtr->proc == NULL);

}

/*

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

 *

 * ThreadExitProc --

 *

 *    This is called when the thread exits.  

 *

 * Results:

 *    None.

 *

 * Side effects:

 *	It unblocks anyone that is waiting on a send to this thread.

 *	It cleans up any events in the event queue for this thread.

 *

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

 */

     /* ARGSUSED */

static void

ThreadExitProc(clientData)

    ClientData clientData;

{

    char *threadEvalScript = (char *) clientData;

    ThreadEventResult *resultPtr, *nextPtr;

    Tcl_ThreadId self = Tcl_GetCurrentThread();

    Tcl_MutexLock(&threadMutex);

    if (threadEvalScript) {

	ckfree((char *) threadEvalScript);

	threadEvalScript = NULL;

    }

    Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);

    for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {