xref: /macosx-10.10.1/tcl-105/tcl_ext/thread/thread/generic/threadCmd.c

/*
 * threadCmd.c --
 *
 * This file implements the Tcl thread commands that allow script
 * level access to threading. It will not load into a core that was
 * not compiled for thread support.
 *
 * See http://www.tcl.tk/doc/howto/thread_model.html
 *
 * 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) 1999,2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: threadCmd.c,v 1.106 2010/04/02 16:49:58 vasiljevic Exp $
 * ----------------------------------------------------------------------------
 */

#include "tclThread.h"

#ifdef NS_AOLSERVER
# include "aolstub.cpp"
#endif

/*
 * Access to the list of threads and to the thread send results
 * (defined below) is guarded by this mutex.
 */

TCL_DECLARE_MUTEX(threadMutex)

/*
 * 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 interpreter can send
 * messages but only the main interpreter can receive them, unless you're
 * not doing asynchronous script backfiring. In such cases the caller might
 * signal the thread to which interpreter the result should be delivered.
 */

typedef struct ThreadSpecificData {
    Tcl_ThreadId threadId;                /* The real ID of this thread */
    Tcl_Interp *interp;                   /* Main interp for this thread */
    Tcl_Condition doOneEvent;             /* Signalled just before running
                                             an event from the event loop */
    int flags;                            /* One of the ThreadFlags below */
    int refCount;                         /* Used for thread reservation */
    int eventsPending;                    /* # of unprocessed events */
    int maxEventsCount;                   /* Maximum # of pending events */
    struct ThreadEventResult  *result;
    struct ThreadSpecificData *nextPtr;
    struct ThreadSpecificData *prevPtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

#define THREAD_FLAGS_NONE          0      /* None */
#define THREAD_FLAGS_STOPPED       1      /* Thread is being stopped */
#define THREAD_FLAGS_INERROR       2      /* Thread is in error */
#define THREAD_FLAGS_UNWINDONERROR 4      /* Thread unwinds on script error */

#define THREAD_RESERVE             1      /* Reserves the thread */
#define THREAD_RELEASE             2      /* Releases the thread */

/*
 * Length of storage for building the Tcl handle for the thread.
 */

#define THREAD_HNDLPREFIX  "tid"
#define THREAD_HNDLMAXLEN  32

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

static struct ThreadSpecificData *threadList = NULL;

/*
 * Used to represent the empty result.
 */

static char *threadEmptyResult = (char *)"";

/*
 * 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 {
    char *script;                         /* Script to execute */
    int flags;                            /* Initial value of the "flags"
                                           * field in ThreadSpecificData */
    Tcl_Condition condWait;               /* Condition variable used to
                                           * sync parent and child threads */
    ClientData cd;                        /* Opaque ptr to pass to thread */
} ThreadCtrl;

/*
 * Structure holding result of the command executed in target thread.
 */

typedef struct ThreadEventResult {
    Tcl_Condition done;                   /* Set when the script completes */
    int code;                             /* Return value of the function */
    char *result;                         /* Result from the function */
    char *errorInfo;                      /* Copy of errorInfo variable */
    char *errorCode;                      /* Copy of errorCode variable */
    Tcl_ThreadId srcThreadId;             /* Id of sender, if it dies */
    Tcl_ThreadId dstThreadId;             /* Id of target, if it dies */
    struct ThreadEvent *eventPtr;         /* Back pointer */
    struct ThreadEventResult *nextPtr;    /* List for cleanup */
    struct ThreadEventResult *prevPtr;
} ThreadEventResult;

/*
 * This list links all active ThreadEventResult structures. This way
 * an exiting thread can inform all threads waiting on jobs posted to
 * his event queue that it is dying, so they might stop waiting.
 */

static ThreadEventResult *resultList;

/*
 * This is the event used to send commands to other threads.
 */

typedef struct ThreadEvent {
    Tcl_Event event;                      /* Must be first */
    struct ThreadSendData *sendData;      /* See below */
    struct ThreadClbkData *clbkData;      /* See below */
    struct ThreadEventResult *resultPtr;  /* To communicate the result back.
                                           * NULL if we don't care about it */
} ThreadEvent;

typedef int  (ThreadSendProc) _ANSI_ARGS_((Tcl_Interp*, ClientData));
typedef void (ThreadSendFree) _ANSI_ARGS_((ClientData));

static ThreadSendProc ThreadSendEval;     /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar;   /* Sets the named variable */

/*
 * These structures are used to communicate commands between source and target
 * threads. The ThreadSendData is used for source->target command passing,
 * while the ThreadClbkData is used for doing asynchronous callbacks.
 *
 * Important: structures below must have first three elements indentical!
 */

typedef struct ThreadSendData {
    ThreadSendProc *execProc;             /* Func to exec in remote thread */
    ClientData clientData;                /* Ptr to pass to send function */
    ThreadSendFree *freeProc;             /* Function to free client data */
     /* ---- */
    Tcl_Interp *interp;                   /* Interp to run the command */
} ThreadSendData;

typedef struct ThreadClbkData {
    ThreadSendProc *execProc;             /* The callback function */
    ClientData clientData;                /* Ptr to pass to clbk function */
    ThreadSendFree *freeProc;             /* Function to free client data */
    /* ---- */
    Tcl_Interp *interp;                   /* Interp to run the command */
    Tcl_ThreadId threadId;                /* Thread where to post callback */
    ThreadEventResult result;             /* Returns result asynchronously */
} ThreadClbkData;

/*
 * Event used to transfer a channel between threads.
 */
typedef struct TransferEvent {
    Tcl_Event event;                      /* Must be first */
    Tcl_Channel chan;                     /* The channel to transfer */
    struct TransferResult *resultPtr;     /* To communicate the result */
} TransferEvent;

typedef struct TransferResult {
    Tcl_Condition done;                   /* Set when transfer is done */
    int resultCode;                       /* Set to TCL_OK or TCL_ERROR when
                                             the transfer is done. Def = -1 */
    char *resultMsg;                      /* Initialized to NULL. Set to a
                                             allocated string by the targer
                                             thread in case of an error  */
    Tcl_ThreadId srcThreadId;             /* Id of src thread, if it dies */
    Tcl_ThreadId dstThreadId;             /* Id of tgt thread, if it dies */
    struct TransferEvent *eventPtr;       /* Back pointer */
    struct TransferResult *nextPtr;       /* Next in the linked list */
    struct TransferResult *prevPtr;       /* Previous in the linked list */
} TransferResult;

static TransferResult *transferList;

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

static Tcl_ThreadId errorThreadId; /* Id of thread to post error message */
static char *errorProcString;      /* Tcl script to run when reporting error */

/*
 * Definition of flags for ThreadSend.
 */

#define THREAD_SEND_WAIT 1<<1
#define THREAD_SEND_HEAD 1<<2

#ifdef BUILD_thread
# undef  TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
#endif

/*
 * Miscelaneous functions used within this file
 */

static Tcl_EventDeleteProc ThreadDeleteEvent;

static Tcl_ThreadCreateType
NewThread         _ANSI_ARGS_((ClientData clientData));

static ThreadSpecificData*
ThreadExistsInner _ANSI_ARGS_((Tcl_ThreadId id));

static int
ThreadInit        _ANSI_ARGS_((Tcl_Interp *interp));

static int
ThreadCreate      _ANSI_ARGS_((Tcl_Interp *interp,
                               const char *script,
                               int stacksize,
                               int flags,
                               int preserve));
static int
ThreadSend        _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId id,
                               ThreadSendData *sendPtr,
                               ThreadClbkData *clbkPtr,
                               int flags));
static void
ThreadSetResult   _ANSI_ARGS_((Tcl_Interp *interp,
                               int code,
                               ThreadEventResult *resultPtr));
static int
ThreadGetOption   _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId id,
                               char *option,
                               Tcl_DString *ds));
static int
ThreadSetOption   _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId id,
                               char *option,
                               char *value));
static int
ThreadReserve     _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId id,
                               int operation,
                               int wait));
static int
ThreadEventProc   _ANSI_ARGS_((Tcl_Event *evPtr,
                               int mask));
static int
ThreadWait        _ANSI_ARGS_((void));

static int
ThreadExists      _ANSI_ARGS_((Tcl_ThreadId id));

static int
ThreadList        _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId **thrIdArray));
static void
ThreadErrorProc   _ANSI_ARGS_((Tcl_Interp *interp));

static void
ThreadFreeProc    _ANSI_ARGS_((ClientData clientData));

static void
ThreadIdleProc    _ANSI_ARGS_((ClientData clientData));

static void
ThreadExitProc    _ANSI_ARGS_((ClientData clientData));

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

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

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

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

static int
ThreadJoin        _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId id));
static int
ThreadTransfer    _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId id,
                               Tcl_Channel chan));
static int
ThreadDetach      _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_Channel chan));
static int
ThreadAttach      _ANSI_ARGS_((Tcl_Interp *interp,
                               char *chanName));
static int
TransferEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
                               int mask));

static void
ThreadGetHandle   _ANSI_ARGS_((Tcl_ThreadId,
                               char *handlePtr));

static int
ThreadGetId       _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_Obj *handleObj,
                               Tcl_ThreadId *thrIdPtr));
static void
ErrorNoSuchThread _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_ThreadId thrId));
static void
ThreadCutChannel  _ANSI_ARGS_((Tcl_Interp *interp,
                               Tcl_Channel channel));

/*
 * Functions implementing Tcl commands
 */

static Tcl_ObjCmdProc ThreadCreateObjCmd;
static Tcl_ObjCmdProc ThreadReserveObjCmd;
static Tcl_ObjCmdProc ThreadReleaseObjCmd;
static Tcl_ObjCmdProc ThreadSendObjCmd;
static Tcl_ObjCmdProc ThreadBroadcastObjCmd;
static Tcl_ObjCmdProc ThreadUnwindObjCmd;
static Tcl_ObjCmdProc ThreadExitObjCmd;
static Tcl_ObjCmdProc ThreadIdObjCmd;
static Tcl_ObjCmdProc ThreadNamesObjCmd;
static Tcl_ObjCmdProc ThreadWaitObjCmd;
static Tcl_ObjCmdProc ThreadExistsObjCmd;
static Tcl_ObjCmdProc ThreadConfigureObjCmd;
static Tcl_ObjCmdProc ThreadErrorProcObjCmd;
static Tcl_ObjCmdProc ThreadJoinObjCmd;
static Tcl_ObjCmdProc ThreadTransferObjCmd;
static Tcl_ObjCmdProc ThreadDetachObjCmd;
static Tcl_ObjCmdProc ThreadAttachObjCmd;

static int
ThreadInit(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{
    Tcl_Obj *boolObjPtr;
    const char *msg;
    int boolVar;

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
        return TCL_ERROR;
    }

    boolObjPtr = Tcl_GetVar2Ex(interp, "::tcl_platform", "threaded", 0);

    if (boolObjPtr == NULL
            || Tcl_GetBooleanFromObj(interp, boolObjPtr, &boolVar) != TCL_OK
            || boolVar == 0) {
        msg = "Tcl core wasn't compiled for threading.";
        Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
        return TCL_ERROR;
    }

    /*
     * We seem to have a Tcl core compiled with threads enabled.
     */

    TCL_CMD(interp, THREAD_CMD_PREFIX"create",    ThreadCreateObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"send",      ThreadSendObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"broadcast", ThreadBroadcastObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"exit",      ThreadExitObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"unwind",    ThreadUnwindObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"id",        ThreadIdObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"names",     ThreadNamesObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"exists",    ThreadExistsObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"wait",      ThreadWaitObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"configure", ThreadConfigureObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"errorproc", ThreadErrorProcObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"preserve",  ThreadReserveObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"release",   ThreadReleaseObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"join",      ThreadJoinObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"transfer",  ThreadTransferObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"detach",    ThreadDetachObjCmd);
    TCL_CMD(interp, THREAD_CMD_PREFIX"attach",    ThreadAttachObjCmd);

    /*
     * Add shared variable commands
     */

    Sv_Init(interp);

    /*
     * Add commands to access thread
     * synchronization primitives.
     */

    Sp_Init(interp);

    /*
     * Add threadpool commands.
     */

    Tpool_Init(interp);

    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Thread_Init --
 *
 *  Initialize the thread commands.
 *
 * Results:
 *  TCL_OK if the package was properly initialized.
 *
 * Side effects:
 *  Adds package commands to the current interp.
 *
 *----------------------------------------------------------------------
 */

EXTERN int
Thread_Init(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{
    int status = ThreadInit(interp);

    if (status != TCL_OK) {
        return status;
    }

    return Tcl_PkgProvide(interp, "Thread", PACKAGE_VERSION);
}

/*
 *----------------------------------------------------------------------
 *
 * Thread_SafeInit --
 *
 *  This function is called from within initialization of the safe
 *  Tcl interpreter.
 *
 * Results:
 *  Standard Tcl result
 *
 * Side effects:
 *  Commands added to the current interpreter,
 *
 *----------------------------------------------------------------------
 */

EXTERN int
Thread_SafeInit(interp)
    Tcl_Interp *interp;
{
    return Thread_Init(interp);
}

/*
 *----------------------------------------------------------------------
 *
 * Init --
 *
 *  Make sure internal list of threads references the current thread.
 *
 * Results:
 *  None
 *
 * Side effects:
 *  The list of threads is initialized to include the current thread.
 *
 *----------------------------------------------------------------------
 */

static void
Init(interp)
    Tcl_Interp *interp;         /* Current interpreter. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->interp == (Tcl_Interp*)NULL) {
        memset(tsdPtr, 0, sizeof(ThreadSpecificData));
        tsdPtr->interp = interp;
        ListUpdate(tsdPtr);
        Tcl_CreateThreadExitHandler(ThreadExitProc,
                                    (ClientData)threadEmptyResult);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadCreateObjCmd --
 *
 *  This procedure is invoked to process the "thread::create" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCreateObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int argc, rsrv = 0;
    const char *arg, *script;
    int flags = TCL_THREAD_NOFLAGS;

    Init(interp);

    /*
     * Syntax: thread::create ?-joinable? ?-preserved? ?script?
     */

    script = THREAD_CMD_PREFIX"wait";

    for (argc = 1; argc < objc; argc++) {
        arg = Tcl_GetStringFromObj(objv[argc], NULL);
        if (OPT_CMP(arg, "--")) {
            argc++;
            if ((argc + 1) == objc) {
                script = Tcl_GetStringFromObj(objv[argc], NULL);
            } else {
                goto usage;
            }
            break;
        } else if (OPT_CMP(arg, "-joinable")) {
            flags |= TCL_THREAD_JOINABLE;
        } else if (OPT_CMP(arg, "-preserved")) {
            rsrv = 1;
        } else if ((argc + 1) == objc) {
            script = Tcl_GetStringFromObj(objv[argc], NULL);
        } else {
            goto usage;
        }
    }

    return ThreadCreate(interp, script, TCL_THREAD_STACK_DEFAULT, flags, rsrv);

 usage:
    Tcl_WrongNumArgs(interp, 1, objv, "?-joinable? ?script?");
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadReserveObjCmd --
 *
 *  This procedure is invoked to process the "thread::preserve" and
 *  "thread::release" Tcl commands, depending on the flag passed by
 *  the ClientData argument. See the user documentation for details
 *  on what those command do.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReserveObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId = (Tcl_ThreadId)0;

    Init(interp);

    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?threadId?");
        return TCL_ERROR;
    }
    if (objc == 2) {
        if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
            return TCL_ERROR;
        }
    }

    return ThreadReserve(interp, thrId, THREAD_RESERVE, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadReleaseObjCmd --
 *
 *  This procedure is invoked to process the "thread::release" Tcl
 *  command. See the user documentation for details on what this
 *  command does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReleaseObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int wait = 0;
    Tcl_ThreadId thrId = (Tcl_ThreadId)0;

    Init(interp);

    if (objc > 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "?-wait? ?threadId?");
        return TCL_ERROR;
    }
    if (objc > 1) {
        if (OPT_CMP(Tcl_GetString(objv[1]), "-wait")) {
            wait = 1;
            if (ThreadGetId(interp, objv[2], &thrId) != TCL_OK) {
                return TCL_ERROR;
            }
        } else if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
            return TCL_ERROR;
        }
    }

    return ThreadReserve(interp, thrId, THREAD_RELEASE, wait);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadUnwindObjCmd --
 *
 *  This procedure is invoked to process the "thread::unwind" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadUnwindObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
    }

    return ThreadReserve(interp, 0, THREAD_RELEASE, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadExitObjCmd --
 *
 *  This procedure is invoked to process the "thread::exit" Tcl
 *  command.  This causes an unconditional close of the thread
 *  and is GUARENTEED to cause memory leaks.  Use this with caution.
 *
 * Results:
 *  Doesn't actually return.
 *
 * Side effects:
 *  Lots.  improper clean up of resources.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExitObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    Init(interp);
    ListRemove(NULL);

    Tcl_ExitThread(666);

    return TCL_OK; /* NOT REACHED */
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadIdObjCmd --
 *
 *  This procedure is invoked to process the "thread::id" Tcl command.
 *  This returns the ID of the current thread.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadIdObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char thrHandle[THREAD_HNDLMAXLEN];

    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
    }

    ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadNamesObjCmd --
 *
 *  This procedure is invoked to process the "thread::names" Tcl
 *  command. This returns a list of all known thread IDs.
 *  These are only threads created via this module (e.g., not
 *  driver threads or the notifier).
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadNamesObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, length;
    char *result, thrHandle[THREAD_HNDLMAXLEN];
    Tcl_ThreadId *thrIdArray;
    Tcl_DString threadNames;

    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
    }

    length = ThreadList(interp, &thrIdArray);

    if (length == 0) {
        return TCL_OK;
    }

    Tcl_DStringInit(&threadNames);

    for (ii = 0; ii < length; ii++) {
        ThreadGetHandle(thrIdArray[ii], thrHandle);
        Tcl_DStringAppendElement(&threadNames, thrHandle);
    }

    length = Tcl_DStringLength(&threadNames);
    result = Tcl_DStringValue(&threadNames);

    Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length));

    Tcl_DStringFree(&threadNames);
    Tcl_Free((char*)thrIdArray);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSendObjCmd --
 *
 *  This procedure is invoked to process the "thread::send" Tcl
 *  command. This sends a script to another thread for execution.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSendObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ret, len, vlen = 0, ii = 0, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg, *var = NULL;

    ThreadClbkData *clbkPtr = NULL;
    ThreadSendData *sendPtr = NULL;

    Init(interp);

    /*
     * Syntax: thread::send ?-async? ?-head? threadId script ?varName?
     */

    if (objc < 3 || objc > 6) {
        goto usage;
    }

    flags = THREAD_SEND_WAIT;

    for (ii = 1; ii < objc; ii++) {
        arg = Tcl_GetStringFromObj(objv[ii], NULL);
        if (OPT_CMP(arg, "-async")) {
            flags &= ~THREAD_SEND_WAIT;
        } else if (OPT_CMP(arg, "-head")) {
            flags |= THREAD_SEND_HEAD;
        } else {
            break;
        }
    }
    if (ii >= objc) {
        goto usage;
    }
    if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) {
        return TCL_ERROR;
    }
    if (++ii >= objc) {
        goto usage;
    }

    script = Tcl_GetStringFromObj(objv[ii], &len);
    if (++ii < objc) {
        var = Tcl_GetStringFromObj(objv[ii], &vlen);
    }
    if (var && (flags & THREAD_SEND_WAIT) == 0) {
        if (thrId == Tcl_GetCurrentThread()) {
            /*
             * FIXME: Do something for callbacks to self
             */
            Tcl_SetResult(interp, "can't notify self", TCL_STATIC);
            return TCL_ERROR;
        }

        /*
         * Prepare record for the callback. This is asynchronously
         * posted back to us when the target thread finishes processing.
         * We should do a vwait on the "var" to get notified.
         */

        clbkPtr = (ThreadClbkData*)Tcl_Alloc(sizeof(ThreadClbkData));
        clbkPtr->execProc   = ThreadClbkSetVar;
        clbkPtr->freeProc   = (ThreadSendFree*)Tcl_Free;
        clbkPtr->interp     = interp;
        clbkPtr->threadId   = Tcl_GetCurrentThread();
        clbkPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+vlen), var);
    }

    /*
     * Prepare job record for the target thread
     */

    sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData));
    sendPtr->interp     = NULL; /* Signal to use thread main interp */
    sendPtr->execProc   = ThreadSendEval;
    sendPtr->freeProc   = (ThreadSendFree*)Tcl_Free;
    sendPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+len), script);

    ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags);

    if (var && (flags & THREAD_SEND_WAIT)) {

        /*
         * Leave job's result in passed variable
         * and return the code, like "catch" does.
         */

        Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
        if (!Tcl_SetVar2Ex(interp, var, NULL, resultObj, TCL_LEAVE_ERR_MSG)) {
            return TCL_ERROR;
        }
        Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
        return TCL_OK;
    }

    return ret;

usage:
    Tcl_WrongNumArgs(interp,1,objv,"?-async? ?-head? id script ?varName?");
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadBroadcastObjCmd --
 *
 *  This procedure is invoked to process the "thread::broadcast" Tcl
 *  command. This asynchronously sends a script to all known threads.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  Script is sent to all known threads except the caller thread.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadBroadcastObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int ii, len, nthreads;
    const char *script;
    Tcl_ThreadId *thrIdArray;
    ThreadSendData *sendPtr, job;

    Init(interp);

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "script");
        return TCL_ERROR;
    }

    script = Tcl_GetStringFromObj(objv[1], &len);

    /*
     * Get the list of known threads. Note that this one may
     * actually change (thread may exit or otherwise cease to
     * exist) while we circle in the loop below. We really do
     * not care about that here since we don't return any
     * script results to the caller.
     */

    nthreads = ThreadList(interp, &thrIdArray);

    if (nthreads == 0) {
        return TCL_OK;
    }

    /*
     * Prepare the structure with the job description
     * to be sent asynchronously to each known thread.
     */

    job.interp     = NULL; /* Signal to use thread's main interp */
    job.execProc   = ThreadSendEval;
    job.freeProc   = (ThreadSendFree*)Tcl_Free;
    job.clientData = NULL;

    /*
     * Now, circle this list and send each thread the script.
     * This is sent asynchronously, since we do not care what
     * are they going to do with it. Also, the event is queued
     * to the head of the event queue (as out-of-band message).
     */

    for (ii = 0; ii < nthreads; ii++) {
        if (thrIdArray[ii] == Tcl_GetCurrentThread()) {
            continue; /* Do not broadcast self */
        }
        sendPtr  = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData));
        *sendPtr = job;
        sendPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+len), script);
        ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD);
    }

    Tcl_Free((char*)thrIdArray);
    Tcl_ResetResult(interp);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadWaitObjCmd --
 *
 *  This procedure is invoked to process the "thread::wait" Tcl
 *  command. This enters the event loop.
 *
 * Results:
 *  Standard Tcl result.
 *
 * Side effects:
 *  Enters the event loop.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadWaitObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Init(interp);

    if (objc > 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
    }

    return ThreadWait();
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadErrorProcObjCmd --
 *
 *  This procedure is invoked to process the "thread::errorproc"
 *  command. This registers a procedure to handle thread errors.
 *  Empty string as the name of the procedure will reset the
 *  default behaviour, which is writing to standard error channel.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  Registers an errorproc.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadErrorProcObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    int len;
    char *proc;

    Init(interp);

    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?proc?");
        return TCL_ERROR;
    }
    Tcl_MutexLock(&threadMutex);
    if (objc == 1) {
        if (errorProcString) {
            Tcl_SetResult(interp, errorProcString, TCL_VOLATILE);
        }
    } else {
        errorThreadId = Tcl_GetCurrentThread();
        if (errorProcString) {
            Tcl_Free(errorProcString);
        }
        proc = Tcl_GetStringFromObj(objv[1], &len);
        if (len == 0) {
            errorProcString = NULL;
        } else {
            errorProcString = Tcl_Alloc(1+strlen(proc));
            strcpy(errorProcString, proc);
        }
    }
    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadJoinObjCmd --
 *
 *  This procedure is invoked to process the "thread::join" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadJoinObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;

    Init(interp);

    /*
     * Syntax of 'join': id
     */

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "id");
        return TCL_ERROR;
    }

    if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
        return TCL_ERROR;
    }

    return ThreadJoin(interp, thrId);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadTransferObjCmd --
 *
 *  This procedure is invoked to process the "thread::transfer" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadTransferObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    Tcl_ThreadId thrId;
    Tcl_Channel chan;

    Init(interp);

    /*
     * Syntax of 'transfer': id channel
     */

    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "id channel");
        return TCL_ERROR;
    }
    if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
        return TCL_ERROR;
    }

    chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), NULL);
    if (chan == (Tcl_Channel)NULL) {
        return TCL_ERROR;
    }

    return ThreadTransfer(interp, thrId, Tcl_GetTopChannel(chan));
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadDetachObjCmd --
 *
 *  This procedure is invoked to process the "thread::detach" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadDetachObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_Channel chan;

    Init(interp);

    /*
     * Syntax: thread::detach channel
     */

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "channel");
        return TCL_ERROR;
    }

    chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
    if (chan == (Tcl_Channel)NULL) {
        return TCL_ERROR;
    }

    return ThreadDetach(interp, Tcl_GetTopChannel(chan));
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadAttachObjCmd --
 *
 *  This procedure is invoked to process the "thread::attach" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadAttachObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *chanName;

    Init(interp);

    /*
     * Syntax: thread::attach channel
     */

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "channel");
        return TCL_ERROR;
    }

    chanName = Tcl_GetString(objv[1]);
    if (Tcl_IsChannelExisting(chanName)) {
        return TCL_OK;
    }

    return ThreadAttach(interp, chanName);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadExistsObjCmd --
 *
 *  This procedure is invoked to process the "thread::exists" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExistsObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    Tcl_ThreadId thrId;

    Init(interp);

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "id");
        return TCL_ERROR;
    }

    if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
        return TCL_ERROR;
    }

    Tcl_SetBooleanObj(Tcl_GetObjResult(interp), ThreadExists(thrId));

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadConfigureObjCmd --
 *
 *	This procedure is invoked to process the Tcl "thread::configure"
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *----------------------------------------------------------------------
 */
static int
ThreadConfigureObjCmd(dummy, interp, objc, objv)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    char *option, *value;
    Tcl_ThreadId thrId;         /* Id of the thread to configure */
    int i;                      /* Iterate over arg-value pairs. */
    Tcl_DString ds;			    /* DString to hold result of
                                 * calling GetThreadOption. */

    if (objc < 2 || (objc % 2 == 1 && objc != 3)) {
        Tcl_WrongNumArgs(interp, 1, objv, "threadlId ?optionName? "
                         "?value? ?optionName value?...");
        return TCL_ERROR;
    }

    Init(interp);

    if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
        return TCL_ERROR;
    }
    if (objc == 2) {
        Tcl_DStringInit(&ds);
        if (ThreadGetOption(interp, thrId, NULL, &ds) != TCL_OK) {
            Tcl_DStringFree(&ds);
            return TCL_ERROR;
        }
        Tcl_DStringResult(interp, &ds);
        return TCL_OK;
    }
    if (objc == 3) {
        Tcl_DStringInit(&ds);
        option = Tcl_GetString(objv[2]);
        if (ThreadGetOption(interp, thrId, option, &ds) != TCL_OK) {
            Tcl_DStringFree(&ds);
            return TCL_ERROR;
        }
        Tcl_DStringResult(interp, &ds);
        return TCL_OK;
    }
    for (i = 3; i < objc; i += 2) {
        option = Tcl_GetString(objv[i-1]);
        value  = Tcl_GetString(objv[i]);
        if (ThreadSetOption(interp, thrId, option, value) != TCL_OK) {
            return TCL_ERROR;
        }
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSendEval --
 *
 *  Evaluates Tcl script passed from source to target thread.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSendEval(interp, clientData)
    Tcl_Interp *interp;
    ClientData clientData;
{
    ThreadSendData *sendPtr = (ThreadSendData*)clientData;
    char *script = (char*)sendPtr->clientData;

    return Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadClbkSetVar --
 *
 *  Sets the Tcl variable in the source thread, as the result
 *  of the asynchronous callback.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  New Tcl variable may be created
 *
 *----------------------------------------------------------------------
 */

static int
ThreadClbkSetVar(interp, clientData)
    Tcl_Interp *interp;
    ClientData clientData;
{
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    const char *var = (const char *)clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;

    /*
     * Get the result of the posted command.
     * We will use it to fill-in the result variable.
     */

    valObj = Tcl_NewStringObj(resultPtr->result, -1);
    if (resultPtr->result != threadEmptyResult) {
        Tcl_Free(resultPtr->result);
    }

    /*
     * Set the result variable
     */

    if (Tcl_SetVar2Ex(interp, var, NULL, valObj,
                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
        return TCL_ERROR;
    }

    /*
     * In case of error, trigger the bgerror mechansim
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            var = "errorCode";
            Tcl_SetVar(interp, var, resultPtr->errorCode, TCL_GLOBAL_ONLY);
            Tcl_Free((char*)resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
            var = "errorInfo";
            Tcl_SetVar(interp, var, resultPtr->errorInfo, TCL_GLOBAL_ONLY);
            Tcl_Free((char*)resultPtr->errorInfo);
        }
        Tcl_SetObjResult(interp, valObj);
        Tcl_BackgroundError(interp);
    }

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

static int
ThreadCreate(interp, script, stacksize, flags, preserve)
    Tcl_Interp *interp;         /* Current interpreter. */
    const char *script;         /* Script to evaluate */
    int         stacksize;      /* Zero for default size */
    int         flags;          /* Zero for no flags */
    int         preserve;       /* If true, reserve the thread */
{
    char thrHandle[THREAD_HNDLMAXLEN];
    ThreadCtrl ctrl;
    Tcl_ThreadId thrId;

#ifdef NS_AOLSERVER
    ctrl.cd = Tcl_GetAssocData(interp, "thread:nsd", NULL);
#endif
    ctrl.script   = (char *)script;
    ctrl.condWait = NULL;
    ctrl.flags    = 0;

    Tcl_MutexLock(&threadMutex);
    if (Tcl_CreateThread(&thrId, NewThread, (ClientData)&ctrl,
            stacksize, flags) != TCL_OK) {
        Tcl_MutexUnlock(&threadMutex);
        Tcl_SetResult(interp, "can't create a new thread", TCL_STATIC);
        return TCL_ERROR;
    }

    /*
     * Wait for the thread to start because it is using
     * the ThreadCtrl argument which is on our stack.
     */

    while (ctrl.script != NULL) {
        Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
    }
    if (preserve) {
        ThreadSpecificData *tsdPtr = ThreadExistsInner(thrId);
        if (tsdPtr == (ThreadSpecificData*)NULL) {
            Tcl_MutexUnlock(&threadMutex);
            Tcl_ConditionFinalize(&ctrl.condWait);
            ErrorNoSuchThread(interp, thrId);
            return TCL_ERROR;
        }
        tsdPtr->refCount++;
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ConditionFinalize(&ctrl.condWait);

    ThreadGetHandle(thrId, thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * NewThread --
 *
 *    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, plus some synchronization primitives. Those are
 *    used so the caller gets signalized when the new thread has
 *    done its initialization.
 *
 *    Space to hold the ThreadControl structure itself is reserved on
 *    the stack of the calling function. The two condition variables
 *    in the ThreadControl structure are destroyed by the calling
 *    function as well. 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
NewThread(clientData)
    ClientData clientData;
{
    ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_Interp *interp;
    int result = TCL_OK, scriptLen;
    char *evalScript;

    /*
     * Initialize the interpreter. The bad thing here is that we
     * assume that initialization of the Tcl interp will be
     * error free, which it may not. In the future we must recover
     * from this and exit gracefully (this is not that easy as
     * it seems on the first glance...)
     */

#ifdef NS_AOLSERVER
    struct mydata *md = (struct mydata*)ctrlPtr->cd;
    Ns_ThreadSetName("-tclthread-");
    interp = (Tcl_Interp*)Ns_TclAllocateInterp(md ? md->server : NULL);
#else
    interp = Tcl_CreateInterp();
    result = Tcl_Init(interp);
#endif

#if !defined(NS_AOLSERVER) || (defined(NS_MAJOR_VERSION) && NS_MAJOR_VERSION >= 4)
    result = Thread_Init(interp);
#endif

    tsdPtr->interp = interp;

    Tcl_MutexLock(&threadMutex);

    /*
     * Update the list of threads.
     */

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

    scriptLen = strlen(ctrlPtr->script);
    evalScript = strcpy((char*)Tcl_Alloc(scriptLen+1), ctrlPtr->script);
    Tcl_CreateThreadExitHandler(ThreadExitProc,(ClientData)evalScript);

    /*
     * Notify the parent we are alive.
     */

    ctrlPtr->script = NULL;
    Tcl_ConditionNotify(&ctrlPtr->condWait);

    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve((ClientData)tsdPtr->interp);
    result = Tcl_EvalEx(tsdPtr->interp, evalScript,scriptLen,TCL_EVAL_GLOBAL);
    if (result != TCL_OK) {
        ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up. Note: add something like TlistRemove for the transfer list.
     */

    if (tsdPtr->doOneEvent) {
        Tcl_ConditionFinalize(&tsdPtr->doOneEvent);
    }

    ListRemove(tsdPtr);

    /*
     * It is up to all other extensions, including Tk, to be responsible
     * for their own events when they receive their Tcl_CallWhenDeleted
     * notice when we delete this interp.
     */

#ifdef NS_AOLSERVER
    Ns_TclMarkForDelete(tsdPtr->interp);
    Ns_TclDeAllocateInterp(tsdPtr->interp);
#else
    Tcl_DeleteInterp(tsdPtr->interp);
#endif
    Tcl_Release((ClientData)tsdPtr->interp);

    /*
     * Tcl_ExitThread calls Tcl_FinalizeThread() indirectly which calls
     * ThreadExitHandlers and cleans the notifier as well as other sub-
     * systems that save thread state data.
     */

    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 */
{
    ThreadSendData *sendPtr;
    const char *argv[3];
    char buf[THREAD_HNDLMAXLEN];
    const char *errorInfo;

    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
    if (errorInfo == NULL) {
        errorInfo = "";
    }

    if (errorProcString == NULL) {
#ifdef NS_AOLSERVER
        Ns_Log(Error, "%s\n%s", Tcl_GetStringResult(interp), errorInfo);
#else
        Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
        if (errChannel == NULL) {
            /* Fixes the [#634845] bug; credits to
             * Wojciech Kocjan <wojciech@kocjan.org> */
            return;
        }
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        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);
#endif
    } else {
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        argv[0] = errorProcString;
        argv[1] = buf;
        argv[2] = errorInfo;

        sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData));
        sendPtr->execProc   = ThreadSendEval;
        sendPtr->freeProc   = (ThreadSendFree*)Tcl_Free;
        sendPtr->clientData = (ClientData) Tcl_Merge(3, argv);
        sendPtr->interp     = NULL;

        ThreadSend(interp, errorThreadId, sendPtr, NULL, 0);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ListUpdate --
 *
 *  Add the thread local storage to the list. This grabs the
 *  mutex to protect the list.
 *
 * Results:
 *  None
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
ListUpdate(tsdPtr)
    ThreadSpecificData *tsdPtr;
{
    if (tsdPtr == NULL) {
        tsdPtr = TCL_TSD_INIT(&dataKey);
    }

    Tcl_MutexLock(&threadMutex);
    ListUpdateInner(tsdPtr);
    Tcl_MutexUnlock(&threadMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * ListUpdateInner --
 *
 *  Add the thread local storage to the list. This assumes the caller
 *  has obtained the threadMutex.
 *
 * Results:
 *  None
 *
 * Side effects:
 *  Add the thread local storage to its list.
 *
 *----------------------------------------------------------------------
 */

static void
ListUpdateInner(tsdPtr)
    ThreadSpecificData *tsdPtr;
{
    if (threadList) {
        threadList->prevPtr = tsdPtr;
    }

    tsdPtr->nextPtr  = threadList;
    tsdPtr->prevPtr  = NULL;
    tsdPtr->threadId = Tcl_GetCurrentThread();

    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);
    ListRemoveInner(tsdPtr);
    Tcl_MutexUnlock(&threadMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * ListRemoveInner --
 *
 *  Remove the thread local storage from its list.
 *
 * Results:
 *  None
 *
 * Side effects:
 *  Remove the thread local storage from its list.
 *
 *----------------------------------------------------------------------
 */

static void
ListRemoveInner(tsdPtr)
    ThreadSpecificData *tsdPtr;
{
    if (tsdPtr->prevPtr || tsdPtr->nextPtr) {
        if (tsdPtr->prevPtr) {
            tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
        } else {
            threadList = tsdPtr->nextPtr;
        }
        if (tsdPtr->nextPtr) {
            tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
        }
        tsdPtr->nextPtr = NULL;
        tsdPtr->prevPtr = NULL;
    } else if (tsdPtr == threadList) {
        threadList = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadList --
 *
 *  Return a list of threads running Tcl interpreters.
 *
 * Results:
 *  Number of threads.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadList(interp, thrIdArray)
    Tcl_Interp *interp;
    Tcl_ThreadId **thrIdArray;
{
    int ii, count = 0;
    ThreadSpecificData *tsdPtr;

    Tcl_MutexLock(&threadMutex);

    /*
     * First walk; find out how many threads are registered.
     * We may avoid this and gain some speed by maintaining
     * the counter of allocated structs in the threadList.
     */

    for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
        count++;
    }

    if (count == 0) {
        return 0;
    }

    /*
     * Allocate storage for passing thread id's to caller
     */

    *thrIdArray = (Tcl_ThreadId*)Tcl_Alloc(count * sizeof(Tcl_ThreadId));

    /*
     * Second walk; fill-in the array with thread ID's
     */

    for (tsdPtr = threadList, ii = 0; tsdPtr; tsdPtr = tsdPtr->nextPtr, ii++) {
        (*thrIdArray)[ii] = tsdPtr->threadId;
    }

    Tcl_MutexUnlock(&threadMutex);

    return count;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadExists --
 *
 *  Test wether a thread given by it's id is known to us.
 *
 * Results:
 *  Pointer to thread specific data structure or
 *  NULL if no thread with given ID found
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExists(thrId)
     Tcl_ThreadId thrId;
{
    ThreadSpecificData *tsdPtr;

    Tcl_MutexLock(&threadMutex);
    tsdPtr = ThreadExistsInner(thrId);
    Tcl_MutexUnlock(&threadMutex);

    return tsdPtr != NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadExistsInner --
 *
 *  Test wether a thread given by it's id is known to us. Assumes
 *  caller holds the thread mutex.
 *
 * Results:
 *  Pointer to thread specific data structure or
 *  NULL if no thread with given ID found
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static ThreadSpecificData *
ThreadExistsInner(thrId)
    Tcl_ThreadId thrId;              /* Thread id to look for. */
{
    ThreadSpecificData *tsdPtr;

    for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
        if (tsdPtr->threadId == thrId) {
            return tsdPtr;
        }
    }

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadJoin --
 *
 *  Wait for the exit of a different thread.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  The status of the exiting thread is left in the interp result
 *  area, but only in the case of success.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadJoin(interp, thrId)
    Tcl_Interp  *interp;        /* The current interpreter. */
    Tcl_ThreadId thrId;         /* Thread ID of other interpreter. */
{
    int ret, state;

    ret = Tcl_JoinThread(thrId, &state);

    if (ret == TCL_OK) {
        Tcl_SetIntObj(Tcl_GetObjResult (interp), state);
    } else {
        char thrHandle[THREAD_HNDLMAXLEN];
        ThreadGetHandle(thrId, thrHandle);
        Tcl_AppendResult(interp, "cannot join thread ", thrHandle, NULL);
    }

    return ret;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadTransfer --
 *
 *  Transfers the specified channel which must not be shared and has
 *  to be registered in the given interp from that location to the
 *  main interp of the specified thread.
 *
 *  Thanks to Anreas Kupries for the initial implementation.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  The thread-global lists of all known channels of both threads
 *  involved (specified and current) are modified. The channel is
 *  moved, all event handling for the channel is killed.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadTransfer(interp, thrId, chan)
    Tcl_Interp *interp;         /* The current interpreter. */
    Tcl_ThreadId thrId;         /* Thread Id of other interpreter. */
    Tcl_Channel  chan;          /* The channel to transfer */
{
    /* Steps to perform for the transfer:
     *
     * i.   Sanity checks: chan has to registered in interp, must not be
     *      shared. This automatically excludes the special channels for
     *      stdin, stdout and stderr!
     * ii.  Clear event handling.
     * iii. Bump reference counter up to prevent destruction during the
     *      following unregister, then unregister the channel from the
     *      interp. Remove it from the thread-global list of all channels
     *      too.
     * iv.  Wrap the channel into an event and send that to the other
     *      thread, then wait for the other thread to process our message.
     * v.   The event procedure called by the other thread is
     *      'TransferEventProc'. It links the channel into the
     *      thread-global list of channels for that thread, registers it
     *      in the main interp of the other thread, removes the artificial
     *      reference, at last notifies this thread of the sucessful
     *      transfer. This allows this thread then to proceed.
     */

    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
        Tcl_SetResult(interp, "channel is not registered here", TCL_STATIC);
    }
    if (Tcl_IsChannelShared(chan)) {
        Tcl_SetResult(interp, "channel is shared", TCL_STATIC);
        return TCL_ERROR;
    }

    /*
     * Short circut transfers to ourself.  Nothing to do.
     */

    if (thrId == Tcl_GetCurrentThread()) {
        return TCL_OK;
    }

    Tcl_MutexLock(&threadMutex);

    /*
     * Verify the thread exists.
     */

    if (ThreadExistsInner(thrId) == NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }

    /*
     * Cut the channel out of the interp/thread
     */

    ThreadCutChannel(interp, chan);

    /*
     * Wrap it into an event.
     */

    resultPtr = (TransferResult*)Tcl_Alloc(sizeof(TransferResult));
    evPtr     = (TransferEvent *)Tcl_Alloc(sizeof(TransferEvent));

    evPtr->chan       = chan;
    evPtr->event.proc = TransferEventProc;
    evPtr->resultPtr  = resultPtr;

    /*
     * Initialize the result fields.
     */

    resultPtr->done       = (Tcl_Condition) NULL;
    resultPtr->resultCode = -1;
    resultPtr->resultMsg  = (char *) NULL;

    /*
     * Maintain the cleanup list.
     */

    resultPtr->srcThreadId = Tcl_GetCurrentThread();
    resultPtr->dstThreadId = thrId;
    resultPtr->eventPtr    = evPtr;

    SpliceIn(resultPtr, transferList);

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

    Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(thrId);

    /*
     * (*) Block until the other thread has either processed the transfer
     * or rejected it.
     */

    while (resultPtr->resultCode < 0) {
        Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
    }

    /*
     * Unlink result from the result list.
     */

    SpliceOut(resultPtr, transferList);

    resultPtr->eventPtr = NULL;
    resultPtr->nextPtr  = NULL;
    resultPtr->prevPtr  = NULL;

    Tcl_MutexUnlock(&threadMutex);

    Tcl_ConditionFinalize(&resultPtr->done);

    /*
     * Process the result now.
     */

    if (resultPtr->resultCode != TCL_OK) {

        /*
         * Transfer failed, restore old state of channel with respect
         * to current thread and specified interp.
         */

        Tcl_SpliceChannel(chan);
        Tcl_RegisterChannel(interp, chan);
        Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
        Tcl_AppendResult(interp, "transfer failed: ", NULL);

        if (resultPtr->resultMsg) {
            Tcl_AppendResult(interp, resultPtr->resultMsg, NULL);
            Tcl_Free(resultPtr->resultMsg);
        } else {
            Tcl_AppendResult(interp, "for reasons unknown", NULL);
        }

        return TCL_ERROR;
    }

    if (resultPtr->resultMsg) {
        Tcl_Free(resultPtr->resultMsg);
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadDetach --
 *
 *  Detaches the specified channel which must not be shared and has
 *  to be registered in the given interp. The detached channel is
 *  left in the transfer list until some other thread attaches it
 +  by calling the "thread::attach" command.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  The thread-global lists of all known channels (transferList)
 *  is modified. All event handling for the channel is killed.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadDetach(interp, chan)
    Tcl_Interp *interp;         /* The current interpreter. */
    Tcl_Channel chan;           /* The channel to detach */
{
    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
        Tcl_SetResult(interp, "channel is not registered here", TCL_STATIC);
    }
    if (Tcl_IsChannelShared(chan)) {
        Tcl_SetResult(interp, "channel is shared", TCL_STATIC);
        return TCL_ERROR;
    }

    /*
     * Cut the channel out of the interp/thread
     */

    ThreadCutChannel(interp, chan);

    /*
     * Wrap it into the list of transfered channels. We generate no
     * events associated with the detached channel, thus really not
     * needing the transfer event structure allocated here. This
     * is done purely to avoid having yet another wrapper.
     */

    resultPtr = (TransferResult*)Tcl_Alloc(sizeof(TransferResult));
    evPtr     = (TransferEvent*)Tcl_Alloc(sizeof(TransferEvent));

    evPtr->chan       = chan;
    evPtr->event.proc = NULL;
    evPtr->resultPtr  = resultPtr;

    /*
     * Initialize the result fields. This is not used.
     */

    resultPtr->done       = (Tcl_Condition)NULL;
    resultPtr->resultCode = -1;
    resultPtr->resultMsg  = (char*)NULL;

    /*
     * Maintain the cleanup list. By setting the dst/srcThreadId
     * to zero we signal the code in ThreadAttach that this is the
     * detached channel. Therefore it should not be mistaken for
     * some regular TransferChannel operation underway. Also, this
     * will prevent the code in ThreadExitProc to splice out this
     * record from the list when the threads are exiting.
     * A side effect of this is that we may have entries in this
     * list which may never be removed (i.e. nobody attaches the
     * channel later on). This will result in both Tcl channel and
     * memory leak.
     */

    resultPtr->srcThreadId = (Tcl_ThreadId)0;
    resultPtr->dstThreadId = (Tcl_ThreadId)0;
    resultPtr->eventPtr    = evPtr;

    Tcl_MutexLock(&threadMutex);
    SpliceIn(resultPtr, transferList);
    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadAttach --
 *
 *  Attaches the previously detached channel into the current
 *  interpreter.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  The thread-global lists of all known channels (transferList)
 *  is modified.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadAttach(interp, chanName)
    Tcl_Interp *interp;         /* The current interpreter. */
    char *chanName;             /* The name of the channel to detach */
{
    int found = 0;
    Tcl_Channel chan = NULL;
    TransferResult *resPtr;

    /*
     * Locate the channel to attach by looking up its name in
     * the list of transfered channels. Watch that we don't
     * hit the regular channel transfer event.
     */

    Tcl_MutexLock(&threadMutex);
    for (resPtr = transferList; resPtr; resPtr = resPtr->nextPtr) {
        chan = resPtr->eventPtr->chan;
        if (!strcmp(Tcl_GetChannelName(chan),chanName)
                && !resPtr->dstThreadId) {
            if (Tcl_IsChannelExisting(chanName)) {
                Tcl_MutexUnlock(&threadMutex);
                Tcl_AppendResult(interp, "channel already exists", NULL);
                return TCL_ERROR;
            }
            SpliceOut(resPtr, transferList);
            Tcl_Free((char*)resPtr->eventPtr);
            Tcl_Free((char*)resPtr);
            found = 1;
            break;
        }
    }
    Tcl_MutexUnlock(&threadMutex);

    if (found == 0) {
        Tcl_AppendResult(interp, "channel not detached", NULL);
        return TCL_ERROR;
    }

    /*
     * Splice channel into the current interpreter
     */

    Tcl_SpliceChannel(chan);
    Tcl_RegisterChannel(interp, chan);
    Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSend --
 *
 *  Run the procedure in other thread.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSend(interp, thrId, send, clbk, flags)
    Tcl_Interp     *interp;      /* The current interpreter. */
    Tcl_ThreadId    thrId;       /* Thread Id of other thread. */
    ThreadSendData *send;        /* Pointer to structure with work to do */
    ThreadClbkData *clbk;        /* Opt. callback structure (may be NULL) */
    int             flags;       /* Wait or queue to tail */
{
    ThreadSpecificData *tsdPtr = NULL; /* ... of the target thread */

    int code;
    ThreadEvent *eventPtr;
    ThreadEventResult *resultPtr;

    /*
     * Verify the thread exists and is not in the error state.
     * The thread is in the error state only if we've configured
     * it to unwind on script evaluation error and last script
     * evaluation resulted in error actually.
     */

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == (ThreadSpecificData*)NULL
            || (tsdPtr->flags & THREAD_FLAGS_INERROR)) {
        int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR);
        Tcl_MutexUnlock(&threadMutex);
        ThreadFreeProc((ClientData)send);
        if (clbk) {
            ThreadFreeProc((ClientData)clbk);
        }
        if (inerror) {
            Tcl_SetResult(interp, "thread is in error", TCL_STATIC);
        } else {
            ErrorNoSuchThread(interp, thrId);
        }
        return TCL_ERROR;
    }

    /*
     * Short circut sends to ourself.
     */

    if (thrId == Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        if ((flags & THREAD_SEND_WAIT)) {
            return (*send->execProc)(interp, (ClientData)send);
        } else {
            send->interp = interp;
            Tcl_Preserve((ClientData)send->interp);
            Tcl_DoWhenIdle((Tcl_IdleProc*)ThreadIdleProc, (ClientData)send);
            return TCL_OK;
        }
    }

    /*
     * Create the event for target thread event queue.
     */

    eventPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent));
    eventPtr->sendData = send;
    eventPtr->clbkData = clbk;

    /*
     * Target thread about to service
     * another event
     */

    if (tsdPtr->maxEventsCount) {
        tsdPtr->eventsPending++;
    }

    /*
     * Caller wants to be notified, so we must take care
     * it's interpreter stays alive until we've finished.
     */

    if (eventPtr->clbkData) {
        Tcl_Preserve((ClientData)eventPtr->clbkData->interp);
    }
    if ((flags & THREAD_SEND_WAIT) == 0) {
        resultPtr              = NULL;
        eventPtr->resultPtr    = NULL;
    } else {
        resultPtr = (ThreadEventResult*)Tcl_Alloc(sizeof(ThreadEventResult));
        resultPtr->done        = (Tcl_Condition)NULL;
        resultPtr->result      = NULL;
        resultPtr->errorCode   = NULL;
        resultPtr->errorInfo   = NULL;
        resultPtr->dstThreadId = thrId;
        resultPtr->srcThreadId = Tcl_GetCurrentThread();
        resultPtr->eventPtr    = eventPtr;

        eventPtr->resultPtr    = resultPtr;

        SpliceIn(resultPtr, resultList);
    }

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

    eventPtr->event.proc = ThreadEventProc;
    if ((flags & THREAD_SEND_HEAD)) {
        Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_HEAD);
    } else {
        Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_TAIL);
    }
    Tcl_ThreadAlert(thrId);

    if ((flags & THREAD_SEND_WAIT) == 0) {
        /*
         * Might potentially spend some time here, until the
         * worker thread clean's up it's queue a little bit.
         */
        while (tsdPtr->maxEventsCount &&
               tsdPtr->eventsPending > tsdPtr->maxEventsCount) {
            Tcl_ConditionWait(&tsdPtr->doOneEvent, &threadMutex, NULL);
        }
        Tcl_MutexUnlock(&threadMutex);
        return TCL_OK;
    }

    /*
     * Block on the result indefinitely.
     */

    Tcl_ResetResult(interp);

    while (resultPtr->result == NULL) {
        Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
    }

    SpliceOut(resultPtr, resultList);

    Tcl_MutexUnlock(&threadMutex);

    /*
     * Return result to caller
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
            Tcl_Free(resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
            Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
            Tcl_Free(resultPtr->errorInfo);
        }
    }

    code = resultPtr->code;
    Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, -1));

    /*
     * Cleanup
     */

    Tcl_ConditionFinalize(&resultPtr->done);
    if (resultPtr->result != threadEmptyResult) {
        Tcl_Free(resultPtr->result);
    }
    Tcl_Free((char*)resultPtr);

    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadWait --
 *
 *  Waits for events and process them as they come, until signaled
 *  to stop.
 *
 * Results:
 *  TCL_OK always
 *
 * Side effects:
 *  Deletes any thread::send or thread::transfer events that are
 *  pending.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadWait()
{
    int canrun = 1;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    /*
     * Process events until signaled to stop.
     */

    while (canrun) {

        /*
         * About to service another event.
         * Wake-up eventual sleepers.
         */

        if (tsdPtr->maxEventsCount) {
            Tcl_MutexLock(&threadMutex);
            tsdPtr->eventsPending--;
            Tcl_ConditionNotify(&tsdPtr->doOneEvent);
            Tcl_MutexUnlock(&threadMutex);
        }
        Tcl_DoOneEvent(TCL_ALL_EVENTS);

        /*
         * Test stop condition under mutex since
         * some other thread may flip our flags.
         */

        Tcl_MutexLock(&threadMutex);
        canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0;
        Tcl_MutexUnlock(&threadMutex);
    }

    /*
     * Remove from the list of active threads, so nobody can post
     * work to this thread, since it is just about to terminate.
     */

    ListRemove(tsdPtr);

    /*
     * Now that the event processor for this thread is closing,
     * delete all pending thread::send and thread::transfer events.
     * These events are owned by us.  We don't delete anyone else's
     * events, but ours.
     */

    Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadReserve --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReserve(interp, thrId, operation, wait)
    Tcl_Interp *interp;                 /* Current interpreter */
    Tcl_ThreadId thrId;                 /* Target thread ID */
    int operation;                      /* THREAD_RESERVE | THREAD_RELEASE */
    int wait;                           /* Wait for thread to exit */
{
    int users, dowait = 0;
    ThreadEvent *evPtr;
    ThreadSpecificData *tsdPtr;

    Tcl_MutexLock(&threadMutex);

    /*
     * Check the given thread
     */

    if (thrId == (Tcl_ThreadId)0) {
        tsdPtr = TCL_TSD_INIT(&dataKey);
    } else {
        tsdPtr = ThreadExistsInner(thrId);
        if (tsdPtr == (ThreadSpecificData*)NULL) {
            Tcl_MutexUnlock(&threadMutex);
            ErrorNoSuchThread(interp, thrId);
            return TCL_ERROR;
        }
    }

    switch (operation) {
    case THREAD_RESERVE: ++tsdPtr->refCount;                break;
    case THREAD_RELEASE: --tsdPtr->refCount; dowait = wait; break;
    }

    users = tsdPtr->refCount;

    if (users <= 0) {

        /*
         * We're last attached user, so tear down the *target* thread
         */

        tsdPtr->flags |= THREAD_FLAGS_STOPPED;

        if (thrId /* Not current! */) {
            ThreadEventResult *resultPtr = NULL;

            /*
             * Remove from the list of active threads, so nobody can post
             * work to this thread, since it is just about to terminate.
             */

            ListRemoveInner(tsdPtr);

            /*
             * Send an dummy event, just to wake-up target thread.
             * It should immediately exit thereafter. We might get
             * stuck here for long time if user really wants to
             * be absolutely sure that the thread has exited.
             */

            if (dowait) {
                resultPtr = (ThreadEventResult*)
                    Tcl_Alloc(sizeof(ThreadEventResult));
                resultPtr->done        = (Tcl_Condition)NULL;
                resultPtr->result      = NULL;
                resultPtr->code        = TCL_OK;
                resultPtr->errorCode   = NULL;
                resultPtr->errorInfo   = NULL;
                resultPtr->dstThreadId = thrId;
                resultPtr->srcThreadId = Tcl_GetCurrentThread();
                SpliceIn(resultPtr, resultList);
            }

            evPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent));
            evPtr->event.proc = ThreadEventProc;
            evPtr->sendData   = NULL;
            evPtr->clbkData   = NULL;
            evPtr->resultPtr  = resultPtr;

            Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
            Tcl_ThreadAlert(thrId);

            if (dowait) {
                while (resultPtr->result == NULL) {
                    Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
                }
                SpliceOut(resultPtr, resultList);
                Tcl_ConditionFinalize(&resultPtr->done);
                if (resultPtr->result != threadEmptyResult) {
                    Tcl_Free(resultPtr->result); /* Will be ignored anyway */
                }
                Tcl_Free((char*)resultPtr);
            }
        }
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);

    return TCL_OK;
}

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

    Tcl_Interp         *interp   = NULL;
    Tcl_ThreadId           thrId = Tcl_GetCurrentThread();
    ThreadEvent        *eventPtr = (ThreadEvent*)evPtr;
    ThreadSendData      *sendPtr = eventPtr->sendData;
    ThreadClbkData      *clbkPtr = eventPtr->clbkData;
    ThreadEventResult* resultPtr = eventPtr->resultPtr;

    int code = TCL_ERROR; /* Pessimistic assumption */

    /*
     * See wether user has any preferences about which interpreter
     * to use for running this job. The job structure might indentify
     * one. If not, just use the thread's main interpreter which is
     * stored in the thread specific data structure.
     * Note that later on we might discover that we're running the
     * aync callback script. In this case, interpreter will be
     * changed to one given in the callback.
     */

    interp = (sendPtr && sendPtr->interp) ? sendPtr->interp : tsdPtr->interp;

    if (interp != NULL) {
        if (clbkPtr && clbkPtr->threadId == thrId) {
            /* Watch: this thread evaluates it's own callback. */
            interp = clbkPtr->interp;
        } else {
            Tcl_Preserve((ClientData)interp);
        }

        Tcl_ResetResult(interp);

        if (sendPtr) {
            Tcl_CreateThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr);
            if (clbkPtr) {
                Tcl_CreateThreadExitHandler(ThreadFreeProc,
                                            (ClientData)clbkPtr);
            }
            code = (*sendPtr->execProc)(interp, (ClientData)sendPtr);
            Tcl_DeleteThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr);
            if (clbkPtr) {
                Tcl_DeleteThreadExitHandler(ThreadFreeProc,
                                            (ClientData)clbkPtr);
            }
        } else {
            code = TCL_OK;
        }
    }

    ThreadFreeProc((ClientData)sendPtr);

    if (resultPtr) {

        /*
         * Report job result synchronously to waiting caller
         */

        Tcl_MutexLock(&threadMutex);
        ThreadSetResult(interp, code, resultPtr);
        Tcl_ConditionNotify(&resultPtr->done);
        Tcl_MutexUnlock(&threadMutex);

    } else if (clbkPtr && clbkPtr->threadId != thrId) {

        ThreadSendData *tmpPtr = (ThreadSendData*)clbkPtr;

        /*
         * Route the callback back to it's originator.
         * Do not wait for the result.
         */

        if (code == TCL_ERROR) {
            ThreadErrorProc(interp);
        }

        ThreadSetResult(interp, code, &clbkPtr->result);
        ThreadSend(interp, clbkPtr->threadId, tmpPtr, NULL, 0);

    } else if (code == TCL_ERROR) {
        /*
         * Only pass errors onto the registered error handler
         * when we don't have a result target for this event.
         */
        ThreadErrorProc(interp);
    }

    if (interp != NULL) {
        Tcl_Release((ClientData)interp);
    }

    /*
     * Mark unwind scenario for this thread if the script resulted
     * in error condition and thread has been marked to unwind.
     * This will cause thread to disappear from the list of active
     * threads, clean-up its event queue and exit.
     */

    if (code != TCL_OK) {
        Tcl_MutexLock(&threadMutex);
        if (tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR) {
            tsdPtr->flags |= THREAD_FLAGS_INERROR;
            if (tsdPtr->refCount == 0) {
                tsdPtr->flags |= THREAD_FLAGS_STOPPED;
            }
        }
        Tcl_MutexUnlock(&threadMutex);
    }

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSetResult --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static void
ThreadSetResult(interp, code, resultPtr)
    Tcl_Interp *interp;
    int code;
    ThreadEventResult *resultPtr;
{
    int reslen;
    const char *errorCode, *errorInfo, *result;

    if (interp == NULL) {
        code      = TCL_ERROR;
        errorInfo = "";
        errorCode = "THREAD";
        result    = "no target interp!";
        reslen    = strlen(result);
        resultPtr->result = (reslen) ?
            strcpy(Tcl_Alloc(1+reslen), result) : threadEmptyResult;
    } else {
        result = Tcl_GetStringResult(interp);
        reslen = strlen(result);
        resultPtr->result = (reslen) ?
            strcpy(Tcl_Alloc(1+reslen), result) : threadEmptyResult;
        if (code == TCL_ERROR) {
            errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
            errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
        } else {
            errorCode = NULL;
            errorInfo = NULL;
        }
    }

    resultPtr->code = code;

    if (errorCode != NULL) {
        resultPtr->errorCode = Tcl_Alloc(1+strlen(errorCode));
        strcpy(resultPtr->errorCode, errorCode);
    } else {
        resultPtr->errorCode = NULL;
    }
    if (errorInfo != NULL) {
        resultPtr->errorInfo = Tcl_Alloc(1+strlen(errorInfo));
        strcpy(resultPtr->errorInfo, errorInfo);
    } else {
        resultPtr->errorInfo = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadGetOption --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadGetOption(interp, thrId, option, dsPtr)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
    char *option;
    Tcl_DString *dsPtr;
{
    int len;
    ThreadSpecificData *tsdPtr = NULL;

    /*
     * If the optionName is NULL it means that we want
     * a list of all options and values.
     */

    len = (option == NULL) ? 0 : strlen(option);

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }

    if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'v'
                     && !strncmp(option,"-eventmark", len))) {
        char buf[16];
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-eventmark");
        }
        sprintf(buf, "%d", tsdPtr->maxEventsCount);
        Tcl_DStringAppendElement(dsPtr, buf);
        if (len != 0) {
            Tcl_MutexUnlock(&threadMutex);
            return TCL_OK;
        }
    }

    if (len == 0 || (len > 2 && option[1] == 'u'
                     && !strncmp(option,"-unwindonerror", len))) {
        int flag = tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR;
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-unwindonerror");
        }
        Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0");
        if (len != 0) {
            Tcl_MutexUnlock(&threadMutex);
            return TCL_OK;
        }
    }

    if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'r'
                     && !strncmp(option,"-errorstate", len))) {
        int flag = tsdPtr->flags & THREAD_FLAGS_INERROR;
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-errorstate");
        }
        Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0");
        if (len != 0) {
            Tcl_MutexUnlock(&threadMutex);
            return TCL_OK;
        }
    }

    if (len != 0) {
        Tcl_AppendResult(interp, "bad option \"", option,
                         "\", should be one of -eventmark, "
                         "-unwindonerror or -errorstate", NULL);
        Tcl_MutexUnlock(&threadMutex);
        return TCL_ERROR;
    }

    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSetOption --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSetOption(interp, thrId, option, value)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
    char *option;
    char *value;
{
    int len = strlen(option);
    ThreadSpecificData *tsdPtr = NULL;

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == (ThreadSpecificData*)NULL) {
        Tcl_MutexUnlock(&threadMutex);
        ErrorNoSuchThread(interp, thrId);
        return TCL_ERROR;
    }
    if (len > 3 && option[1] == 'e' && option[2] == 'v'
        && !strncmp(option,"-eventmark", len)) {
        if (sscanf(value, "%d", &tsdPtr->maxEventsCount) != 1) {
            Tcl_AppendResult(interp, "expected integer but got \"",
                             value, "\"", NULL);
            Tcl_MutexUnlock(&threadMutex);
            return TCL_ERROR;
        }
    } else if (len > 2 && option[1] == 'u'
               && !strncmp(option,"-unwindonerror", len)) {
        int flag = 0;
        if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) {
            Tcl_MutexUnlock(&threadMutex);
            return TCL_ERROR;
        }
        if (flag) {
            tsdPtr->flags |=  THREAD_FLAGS_UNWINDONERROR;
        } else {
            tsdPtr->flags &= ~THREAD_FLAGS_UNWINDONERROR;
        }
    } else if (len > 3 && option[1] == 'e' && option[2] == 'r'
               && !strncmp(option,"-errorstate", len)) {
        int flag = 0;
        if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) {
            Tcl_MutexUnlock(&threadMutex);
            return TCL_ERROR;
        }
        if (flag) {
            tsdPtr->flags |=  THREAD_FLAGS_INERROR;
        } else {
            tsdPtr->flags &= ~THREAD_FLAGS_INERROR;
        }
    }

    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadIdleProc --
 *
 * Results:
 *
 * Side effects.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadIdleProc(clientData)
    ClientData clientData;
{
    int ret;
    ThreadSendData *sendPtr = (ThreadSendData*)clientData;

    ret = (*sendPtr->execProc)(sendPtr->interp, (ClientData)sendPtr);
    if (ret != TCL_OK) {
        ThreadErrorProc(sendPtr->interp);
    }

    Tcl_Release((ClientData)sendPtr->interp);
}

/*
 *----------------------------------------------------------------------
 *
 * TransferEventProc --
 *
 *  Handle a transfer event in the target thread.
 *
 * Results:
 *  Returns 1 to indicate that the event was processed.
 *
 * Side effects:
 *  Fills out the TransferResult struct.
 *
 *----------------------------------------------------------------------
 */

static int
TransferEventProc(evPtr, mask)
    Tcl_Event *evPtr;           /* Really ThreadEvent */
    int mask;
{
    ThreadSpecificData    *tsdPtr = TCL_TSD_INIT(&dataKey);
    TransferEvent       *eventPtr = (TransferEvent *)evPtr;
    TransferResult     *resultPtr = eventPtr->resultPtr;
    Tcl_Interp            *interp = tsdPtr->interp;
    int code;
    const char* msg = NULL;

    if (interp == NULL) {
        /*
         * Reject transfer in case of a missing target.
         */
        code = TCL_ERROR;
        msg  = "target interp missing";
    } else {
        /*
         * Add channel to current thread and interp.
         * See ThreadTransfer for more explanations.
         */
        if (Tcl_IsChannelExisting(Tcl_GetChannelName(eventPtr->chan))) {
            /*
             * Reject transfer. Channel of same name already exists in target.
             */
            code = TCL_ERROR;
            msg  = "channel already exists in target";
        } else {
            Tcl_SpliceChannel(eventPtr->chan);
            Tcl_RegisterChannel(interp, eventPtr->chan);
            Tcl_UnregisterChannel((Tcl_Interp *) NULL, eventPtr->chan);
            code = TCL_OK; /* Return success. */
        }
    }
    if (resultPtr) {
        Tcl_MutexLock(&threadMutex);
        resultPtr->resultCode = code;
        if (msg != NULL) {
            resultPtr->resultMsg = (char*)Tcl_Alloc(1+strlen (msg));
            strcpy (resultPtr->resultMsg, msg);
        }
        Tcl_ConditionNotify(&resultPtr->done);
        Tcl_MutexUnlock(&threadMutex);
    }

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadFreeProc --
 *
 *  Called when we are exiting and memory needs to be freed.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Clears up mem specified in ClientData
 *
 *----------------------------------------------------------------------
 */
static void
ThreadFreeProc(clientData)
    ClientData clientData;
{
    /*
     * This will free send and/or callback structures
     * since both are the same in the beginning.
     */

    ThreadSendData *anyPtr = (ThreadSendData*)clientData;

    if (anyPtr) {
        if (anyPtr->clientData) {
            (*anyPtr->freeProc)(anyPtr->clientData);
        }
        Tcl_Free((char*)anyPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadDeleteEvent(eventPtr, clientData)
    Tcl_Event *eventPtr;        /* Really ThreadEvent */
    ClientData clientData;      /* dummy */
{
    if (eventPtr->proc == ThreadEventProc) {
        /*
         * Regular script event. Just dispose memory
         */
        ThreadEvent *evPtr = (ThreadEvent*)eventPtr;
        if (evPtr->sendData) {
            ThreadFreeProc((ClientData)evPtr->sendData);
        }
        if (evPtr->clbkData) {
            ThreadFreeProc((ClientData)evPtr->clbkData);
        }
        return 1;
    }
    if ((eventPtr->proc == TransferEventProc)) {
        /*
         * A channel is in flight toward the thread just exiting.
         * Pass it back to the originator, if possible.
         * Else kill it.
         */
        TransferEvent* evPtr = (TransferEvent *) eventPtr;

        if (evPtr->resultPtr == (TransferResult *) NULL) {
            /* No thread to pass the channel back to. Kill it.
             * This requires to splice it temporarily into our channel
             * list and then forcing the ref.counter down to the real
             * value of zero. This destroys the channel.
             */

            Tcl_SpliceChannel(evPtr->chan);
            Tcl_UnregisterChannel((Tcl_Interp *) NULL, evPtr->chan);
            return 1;
        }

        /* Our caller (ThreadExitProc) will pass the channel back.
         */

        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.
 *
 *----------------------------------------------------------------------
 */
static void
ThreadExitProc(clientData)
    ClientData clientData;
{
    char *threadEvalScript = (char*)clientData;
    const char *diemsg = "target thread died";
    ThreadEventResult *resultPtr, *nextPtr;
    Tcl_ThreadId self = Tcl_GetCurrentThread();
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    TransferResult *tResultPtr, *tNextPtr;

    if (threadEvalScript && threadEvalScript != threadEmptyResult) {
        Tcl_Free((char*)threadEvalScript);
    }

    Tcl_MutexLock(&threadMutex);

    /*
     * AOLserver and threadpool threads get started/stopped
     * out of the control of this interface so this is
     * the first chance to split them out of the thread list.
     */

    ListRemoveInner(tsdPtr);

    /*
     * Delete events posted to our queue while we were running.
     * For threads exiting from the thread::wait command, this
     * has already been done in ThreadWait() function.
     * For one-shot threads, having something here is a very
     * strange condition. It *may* happen if somebody posts us
     * an event while we were in the middle of processing some
     * lengthly user script. It is unlikely to happen, though.
     */

    Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL);

    /*
     * Walk the list of threads waiting for result from us
     * and inform them that we're about to exit.
     */

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

            SpliceOut(resultPtr, resultList);
            Tcl_Free((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.
             */

            resultPtr->result = strcpy(Tcl_Alloc(1+strlen(diemsg)), diemsg);
            resultPtr->code = TCL_ERROR;
            resultPtr->errorCode = resultPtr->errorInfo = NULL;
            Tcl_ConditionNotify(&resultPtr->done);
        }
    }
    for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
        tNextPtr = tResultPtr->nextPtr;
        if (tResultPtr->srcThreadId == self) {
            /*
             * We are going away. By freeing up the result we signal
             * to the other thread we don't care about the result.
             *
             * This should not happen, as this thread should be in
             * ThreadTransfer at location (*).
             */

            SpliceOut(tResultPtr, transferList);
            Tcl_Free((char*)tResultPtr);

        } else if (tResultPtr->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.
             */

            tResultPtr->resultMsg = strcpy(Tcl_Alloc(1+strlen(diemsg)),
                                           diemsg);
            tResultPtr->resultCode = TCL_ERROR;
            Tcl_ConditionNotify(&tResultPtr->done);
        }
    }
    Tcl_MutexUnlock(&threadMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadGetHandle --
 *
 *  Construct the handle of the thread which is suitable
 *  to pass to Tcl.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadGetHandle(thrId, handlePtr)
    Tcl_ThreadId thrId;
    char *handlePtr;
{
    sprintf(handlePtr, THREAD_HNDLPREFIX"%p", thrId);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadGetId --
 *
 *  Returns the ID of thread given it's Tcl handle.
 *
 * Results:
 *  Thread ID.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadGetId(interp, handleObj, thrIdPtr)
     Tcl_Interp *interp;
     Tcl_Obj *handleObj;
     Tcl_ThreadId *thrIdPtr;
{
    const char *thrHandle = Tcl_GetStringFromObj(handleObj, NULL);

    if (sscanf(thrHandle, THREAD_HNDLPREFIX"%p", thrIdPtr) == 1) {
        return TCL_OK;
    }

    Tcl_AppendResult(interp, "invalid thread handle \"",
                     thrHandle, "\"", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 *  ErrorNoSuchThread --
 *
 *  Convenience function to set interpreter result when the thread
 *  given by it's ID cannot be found.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
ErrorNoSuchThread(interp, thrId)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
{
    char thrHandle[THREAD_HNDLMAXLEN];

    ThreadGetHandle(thrId, thrHandle);
    Tcl_AppendResult(interp, "thread \"", thrHandle,
                     "\" does not exist", NULL);
}

/*
 *----------------------------------------------------------------------
 *
 *  ThreadCutChannel --
 *
 *  Dissociate a Tcl channel from the current thread/interp.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Events still pending in the thread event queue and ready to fire
 *  are not processed.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadCutChannel(interp, chan)
    Tcl_Interp *interp;
    Tcl_Channel chan;
{
    const Tcl_ChannelType *chanTypePtr;
    Tcl_DriverWatchProc *watchProc;

    Tcl_ClearChannelHandlers(chan);

    chanTypePtr = Tcl_GetChannelType(chan);
    watchProc   = Tcl_ChannelWatchProc(chanTypePtr);

    /*
     * This effectively disables processing of pending
     * events which are ready to fire for the given
     * channel. If we do not do this, events will hit
     * the detached channel which is potentially being
     * owned by some other thread. This will wreck havoc
     * on our memory and eventually badly hurt us...
     */

    if (watchProc) {
        (*watchProc)(Tcl_GetChannelInstanceData(chan), 0);
    }

    /*
     * Artificially bump the channel reference count
     * which protects us from channel being closed
     * during the Tcl_UnregisterChannel().
     */

    Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
    Tcl_UnregisterChannel(interp, chan);

    Tcl_CutChannel(chan);
}

/* EOF $RCSfile: threadCmd.c,v $ */

/* Emacs Setup Variables */
/* Local Variables:      */
/* mode: C               */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4     */
/* End:                  */