text: /*
   * 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.
   * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
   *
   * See the file "license.terms" for information on usage and redistribution of
   * this file, and for a DISCLAIMER OF ALL WARRANTIES.
   */
  
  #ifndef USE_TCL_STUBS
  #   define USE_TCL_STUBS
  #endif
  #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 ThreadSpecificData *threadList = NULL;
  
  /*
   * The following bit-values are legal for the "flags" field of the
   * ThreadSpecificData structure.
   */
  
  #define TP_Dying		0x001 /* This thread is being canceled */
  
  /*
   * 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 ThreadCreate() C function.
   */
  
  typedef struct ThreadCtrl {
      const 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 mainThreadId;
  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)
  
  static int		ThreadObjCmd(ClientData clientData,
  			    Tcl_Interp *interp, int objc,
  			    Tcl_Obj *const objv[]);
  static int		ThreadCreate(Tcl_Interp *interp, const char *script,
  			    int joinable);
  static int		ThreadList(Tcl_Interp *interp);
  static int		ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
  			    const char *script, int wait);
  static int		ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
  			    const char *result, int flags);
  
  static Tcl_ThreadCreateType	NewTestThread(ClientData clientData);
  static void		ListRemove(ThreadSpecificData *tsdPtr);
  static void		ListUpdateInner(ThreadSpecificData *tsdPtr);
  static int		ThreadEventProc(Tcl_Event *evPtr, int mask);
  static void		ThreadErrorProc(Tcl_Interp *interp);
  static void		ThreadFreeProc(ClientData clientData);
  static int		ThreadDeleteEvent(Tcl_Event *eventPtr,
  			    ClientData clientData);
  static void		ThreadExitProc(ClientData clientData);
  extern int		Tcltest_Init(Tcl_Interp *interp);
  
  /*
   *----------------------------------------------------------------------
   *
   * 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(
      Tcl_Interp *interp)		/* The current Tcl interpreter */
  {
      /*
       * If the main thread Id has not been set, do it now.
       */
  
      Tcl_MutexLock(&threadMutex);
      if (mainThreadId == 0) {
  	mainThreadId = Tcl_GetCurrentThread();
      }
      Tcl_MutexUnlock(&threadMutex);
  
      Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
      return TCL_OK;
  }
  
  /*
   *----------------------------------------------------------------------
   *
   * ThreadObjCmd --
   *
   *	This procedure is invoked to process the "testthread" Tcl command. See
   *	the user documentation for details on what it does.
   *
   *	thread cancel ?-unwind? id ?result?
   *	thread create ?-joinable? ?script?
   *	thread send ?-async? id script
   *	thread event
   *	thread exit
   *	thread id ?-main?
   *	thread names
   *	thread wait
   *	thread errorproc proc
   *	thread join id
   *
   * Results:
   *	A standard Tcl result.
   *
   * Side effects:
   *	See the user documentation.
   *
   *----------------------------------------------------------------------
   */
  
  	/* ARGSUSED */
  static int
  ThreadObjCmd(
      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 *const threadOptions[] = {
  	"cancel", "create", "event", "exit", "id",
  	"join", "names", "send", "wait", "errorproc",
  	NULL
      };
      enum options {
  	THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT,
  	THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND,
  	THREAD_WAIT, THREAD_ERRORPROC
      };
  
      if (objc < 2) {
  	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
  	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_CANCEL: {
  	Tcl_WideInt id;
  	const char *result;
  	int flags, arg;
  
  	if ((objc < 3) || (objc > 5)) {
  	    Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?");
  	    return TCL_ERROR;
  	}
  	flags = 0;
  	arg = 2;
  	if ((objc == 4) || (objc == 5)) {
  	    if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) {
  		flags = TCL_CANCEL_UNWIND;
  		arg++;
  	    }
  	}
  	if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
  	    return TCL_ERROR;
  	}
  	arg++;
  	if (arg < objc) {
  	    result = Tcl_GetString(objv[arg]);
  	} else {
  	    result = NULL;
  	}
  	return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags);
      }
      case THREAD_CREATE: {
  	const char *script;
  	int joinable, len;
  
  	if (objc == 2) {
  	    /*
  	     * Neither joinable nor special script
  	     */
  
  	    joinable = 0;
  	    script = "testthread wait";		/* Just enter event loop */
  	} else if (objc == 3) {
  	    /*
  	     * Possibly -joinable, then no special script, no joinable, then
  	     * its a script.
  	     */
  
  	    script = Tcl_GetStringFromObj(objv[2], &len);
  
  	    if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
  		    (0 == strncmp(script, "-joinable", (size_t) len))) {
  		joinable = 1;
  		script = "testthread wait";	/* Just enter event loop */
  	    } else {
  		/*
  		 * Remember the script
  		 */
  
  		joinable = 0;
  	    }
  	} else if (objc == 4) {
  	    /*
  	     * Definitely a script available, but is the flag -joinable?
  	     */
  
  	    script = Tcl_GetStringFromObj(objv[2], &len);
  	    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 ThreadCreate(interp, script, joinable);
      }
      case THREAD_EXIT:
  	if (objc > 2) {
  	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
  	    return TCL_ERROR;
  	}
  	ListRemove(NULL);
  	Tcl_ExitThread(0);
  	return TCL_OK;
      case THREAD_ID:
  	if (objc == 2 || objc == 3) {
  	    Tcl_Obj *idObj;
  
  	    /*
  	     * Check if they want the main thread id or the current thread id.
  	     */
  
  	    if (objc == 2) {
  		idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
  	    } else if (objc == 3
  		    && strcmp("-main", Tcl_GetString(objv[2])) == 0) {
  		Tcl_MutexLock(&threadMutex);
  		idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId);
  		Tcl_MutexUnlock(&threadMutex);
  	    } else {
  		Tcl_WrongNumArgs(interp, 2, objv, NULL);
  		return TCL_ERROR;
  	    }
  
  	    Tcl_SetObjResult(interp, idObj);
  	    return TCL_OK;
  	} else {
  	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
  	    return TCL_ERROR;
  	}
      case THREAD_JOIN: {
  	Tcl_WideInt id;
  	int result, status;
  
  	if (objc != 3) {
  	    Tcl_WrongNumArgs(interp, 2, objv, "id");
  	    return TCL_ERROR;
  	}
  	if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
  	    return TCL_ERROR;
  	}
  
  	result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
  	if (result == TCL_OK) {
  	    Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
  	} else {
  	    char buf[20];
  
  	    sprintf(buf, "%" TCL_LL_MODIFIER "d", 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 ThreadList(interp);
      case THREAD_SEND: {
  	Tcl_WideInt id;
  	const char *script;
  	int wait, arg;
  
  	if ((objc != 4) && (objc != 5)) {
  	    Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
  	    return TCL_ERROR;
  	}
  	if (objc == 5) {
  	    if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
  		Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
  		return TCL_ERROR;
  	    }
  	    wait = 0;
  	    arg = 3;
  	} else {
  	    wait = 1;
  	    arg = 2;
  	}
  	if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
  	    return TCL_ERROR;
  	}
  	arg++;
  	script = Tcl_GetString(objv[arg]);
  	return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
      }
      case THREAD_EVENT: {
  	if (objc > 2) {
  	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
  	    return TCL_ERROR;
  	}
  	Tcl_SetObjResult(interp, Tcl_NewIntObj(
  		Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
  	return TCL_OK;
      }
      case THREAD_ERRORPROC: {
  	/*
  	 * Arrange for this proc to handle thread death errors.
  	 */
  
  	const char *proc;
  
  	if (objc != 3) {
  	    Tcl_WrongNumArgs(interp, 2, objv, "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;
      }
      case THREAD_WAIT:
  	if (objc > 2) {
  	    Tcl_WrongNumArgs(interp, 2, objv, "");
  	    return TCL_ERROR;
  	}
  	while (1) {
  	    /*
  	     * If the script has been unwound, bail out immediately. This does
  	     * not follow the recommended guidelines for how extensions should
  	     * handle the script cancellation functionality because this is
  	     * not a "normal" extension. Most extensions do not have a command
  	     * that simply enters an infinite Tcl event loop. Normal
  	     * extensions should not specify the TCL_CANCEL_UNWIND when
  	     * calling Tcl_Canceled to check if the command has been canceled.
  	     */
  
  	    if (Tcl_Canceled(interp,
  		    TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
  		break;
  	    }
  	    (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
  	}
  
  	/*
  	 * If we get to this point, we have been canceled by another thread,
  	 * which is considered to be an "error".
  	 */
  
  	ThreadErrorProc(interp);
  	return TCL_OK;
      }
      return TCL_OK;
  }
  
  /*
   *----------------------------------------------------------------------
   *
   * ThreadCreate --
   *
   *	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 */
  static int
  ThreadCreate(
      Tcl_Interp *interp,		/* Current interpreter. */
      const 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);
  	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_NewWideIntObj((Tcl_WideInt)(size_t)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)
  {
      ThreadCtrl *ctrlPtr = 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);
      if (result != TCL_OK) {
  	ThreadErrorProc(tsdPtr->interp);
      }
  
      /*
       * This is part of the test facility. Initialize _ALL_ test commands for
       * use by the new thread.
       */
  
      result = Tcltest_Init(tsdPtr->interp);
      if (result != TCL_OK) {
  	ThreadErrorProc(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 = ckalloc(strlen(ctrlPtr->script) + 1);
      strcpy(threadEvalScript, ctrlPtr->script);
  
      Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
  
      /*
       * Notify the parent we are alive.
       */
  
      Tcl_ConditionNotify(&ctrlPtr->condWait);
      Tcl_MutexUnlock(&threadMutex);
  
      /*
       * Run the script.
       */
  
      Tcl_Preserve(tsdPtr->interp);
      result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0);
      if (result != TCL_OK) {
  	ThreadErrorProc(tsdPtr->interp);
      }
  
      /*
       * Clean up.
       */
  
      Tcl_DeleteInterp(tsdPtr->interp);
      Tcl_Release(tsdPtr->interp);
      ListRemove(tsdPtr);
      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(
      Tcl_Interp *interp)		/* Interp that failed */
  {
      Tcl_Channel errChannel;
      const char *errorInfo, *argv[3];
      char *script;
      char buf[TCL_DOUBLE_SPACE+1];
  
      sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)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);
  	ThreadSend(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(
      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(
      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;
      tsdPtr->interp = NULL;
      Tcl_MutexUnlock(&threadMutex);
  }
  
  /*
   *------------------------------------------------------------------------
   *
   * ThreadList --
   *
   *    Return a list of threads running Tcl interpreters.
   *
   * Results:
   *    A standard Tcl result.
   *
   * Side effects:
   *    None.
   *
   *------------------------------------------------------------------------
   */
  static int
  ThreadList(
      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_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId));
      }
      Tcl_MutexUnlock(&threadMutex);
      Tcl_SetObjResult(interp, listPtr);
      return TCL_OK;
  }
  
  /*
   *------------------------------------------------------------------------
   *
   * ThreadSend --
   *
   *    Send a script to another thread.
   *
   * Results:
   *    A standard Tcl result.
   *
   * Side effects:
   *    None.
   *
   *------------------------------------------------------------------------
   */
  
  static int
  ThreadSend(
      Tcl_Interp *interp,		/* The current interpreter. */
      Tcl_ThreadId id,		/* Thread Id of other interpreter. */
      const 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_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
      }
  
      /*
       * Create the event for its event queue.
       */
  
      threadEventPtr = ckalloc(sizeof(ThreadEvent));
      threadEventPtr->script = ckalloc(strlen(script) + 1);
      strcpy(threadEventPtr->script, script);
      if (!wait) {
  	resultPtr = threadEventPtr->resultPtr = NULL;
      } else {
  	resultPtr = 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_AppendResult(interp, resultPtr->result, NULL);
      Tcl_ConditionFinalize(&resultPtr->done);
      code = resultPtr->code;
  
      ckfree(resultPtr->result);
      ckfree(resultPtr);
  
      return code;
  }
  
  /*
   *------------------------------------------------------------------------
   *
   * ThreadCancel --
   *
   *    Cancels a script in another thread.
   *
   * Results:
   *    A standard Tcl result.
   *
   * Side effects:
   *    None.
   *
   *------------------------------------------------------------------------
   */
  
  static int
  ThreadCancel(
      Tcl_Interp *interp,		/* The current interpreter. */
      Tcl_ThreadId id,		/* Thread Id of other interpreter. */
      const char *result,		/* The result or NULL for default. */
      int flags)			/* Flags for Tcl_CancelEval. */
  {
      ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
      int found;
      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;
      }
  
      /*
       * Since Tcl_CancelEval can be safely called from any thread,
       * we do it now.
       */
  
      Tcl_MutexUnlock(&threadMutex);
      Tcl_ResetResult(interp);
      return Tcl_CancelEval(tsdPtr->interp,
      	(result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
  }
  
  /*
   *------------------------------------------------------------------------
   *
   * 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(
      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(interp);
  	Tcl_ResetResult(interp);
  	Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
  	code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
  	Tcl_DeleteThreadExitHandler(ThreadFreeProc, 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(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)
  {
      if (clientData) {
  	ckfree(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(
      Tcl_Event *eventPtr,	/* Really ThreadEvent */
      ClientData clientData)	/* dummy */
  {
      if (eventPtr->proc == ThreadEventProc) {
  	ckfree(((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)
  {
      char *threadEvalScript = clientData;
      ThreadEventResult *resultPtr, *nextPtr;
      Tcl_ThreadId self = Tcl_GetCurrentThread();
      ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  
      if (tsdPtr->interp != NULL) {
  	ListRemove(tsdPtr);
      }
  
      Tcl_MutexLock(&threadMutex);
  
      if (self == errorThreadId) {
  	if (errorProcString) {	/* Extra safety */
  	    ckfree(errorProcString);
  	    errorProcString = NULL;
  	}
  	errorThreadId = 0;
      }
  
      if (threadEvalScript) {
  	ckfree(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(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.
  	     */
  
  	    const 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 */
  
  /*
   * Local Variables:
   * mode: c
   * c-basic-offset: 4
   * fill-column: 78
   * End:
   */
  