/* 

  * 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) {

 	nextPtr = resultPtr->nextPtr;

 	if (resultPtr->srcThreadId == self) {

 	    /*

 	     * We are going away.  By freeing up the result we signal

 	     * to the other thread we don't care about the result.

 	     */

 	    if (resultPtr->prevPtr) {

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

 	    } else {

 		resultList = resultPtr->nextPtr;

 	    }

 	    if (resultPtr->nextPtr) {

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

 	    }

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

 	    resultPtr->eventPtr->resultPtr = NULL;

 	    ckfree((char *)resultPtr);

 	} else if (resultPtr->dstThreadId == self) {

 	    /*

 	     * Dang.  The target is going away.  Unblock the caller.

 	     * The result string must be dynamically allocated because

 	     * the main thread is going to call free on it.

 	     */

 	    char *msg = "target thread died";

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

 	    strcpy(resultPtr->result, msg);

 	    resultPtr->code = TCL_ERROR;

 	    Tcl_ConditionNotify(&resultPtr->done);

 	}

     }

     Tcl_MutexUnlock(&threadMutex);

 }

 #endif /* TCL_THREADS */