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

#include "tclThreadInt.h"
#include "threadSvCmd.h"
#include "threadUuid.h"

/*
 * Provide package version in build contexts which do not provide
 * -DPACKAGE_VERSION, like building a shell with the Thread object
 * files built as part of that shell. Example: basekits.
 */
#ifndef PACKAGE_VERSION
#define PACKAGE_VERSION "3.0.2"
#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 */
    size_t 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 */
    void *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) (Tcl_Interp*, void *);
typedef void (ThreadSendFree) (void *);

static ThreadSendProc ThreadSendEval;     /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar;   /* Sets the named variable */
static ThreadSendProc ThreadClbkCommand;   /* 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 identical!
 */

typedef struct ThreadSendData {
    ThreadSendProc *execProc;             /* Func to exec in remote thread */
    void *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 */
    void *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 target
					     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)
#define THREAD_SEND_CLBK (1<<3)

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

/*
 * Miscellaneous functions used within this file
 */

static Tcl_EventDeleteProc ThreadDeleteEvent;

static Tcl_ThreadCreateType
NewThread(void *clientData);

static ThreadSpecificData*
ThreadExistsInner(Tcl_ThreadId id);

static const char *
ThreadInit(Tcl_Interp *interp);

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

static int
ThreadExists(Tcl_ThreadId id);

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

static void
ThreadFreeProc(void *clientData);

static void
ThreadExitProc(void *clientData);

static void
ThreadFreeError(void *clientData);

static void
ListRemove(ThreadSpecificData *tsdPtr);

static void
ListRemoveInner(ThreadSpecificData *tsdPtr);

static void
ListUpdate(ThreadSpecificData *tsdPtr);

static void
ListUpdateInner(ThreadSpecificData *tsdPtr);

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

static void
ThreadGetHandle(Tcl_ThreadId,
			       char *handlePtr);

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

static int
ThreadCancel(Tcl_Interp *interp,
			       Tcl_ThreadId thrId,
			       const char *result,
			       int flags);

/*
 * Functions implementing Tcl commands
 */

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

#ifndef STRINGIFY
#  define STRINGIFY(x) STRINGIFY1(x)
#  define STRINGIFY1(x) #x
#endif

static const char *
ThreadInit(
    Tcl_Interp *interp /* The current Tcl interpreter */
) {
    /* Tcl 8.7 interps are only supported on 32-bit machines.
     * Lower than that is never supported. Bye!
     */
#if defined(TCL_WIDE_INT_IS_LONG) && TCL_MAJOR_VERSION < 9
#   error "Thread 3.0 is only supported with Tcl 9.0 and higher."
#	error "Please use Thread 2.8 (branch thread-2-8-branch)"
#endif

	/* Even though it's not supported, Thread 3.0 works with Tcl 8.7
	 * on 32-bit platforms, so allow that for now. It could be that
	 * Tcl 9.0 introduces a further binary incompatibility in the
	 * future, so this is not guaranteed to stay like it is now!
	 */
    const char *ver = (sizeof(size_t) == sizeof(int))? "8.7-": "9.0";

    if (!((Tcl_InitStubs)(interp, ver, (TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16),
	    TCL_STUB_MAGIC))) {
	return NULL;
    }

    if (threadMutex == NULL){
	Tcl_MutexLock(&threadMutex);
	if (threadMutex == NULL){
	    /* If threadMutex==NULL here, it means that Tcl_MutexLock() is
	     * a dummy function, which is the case in unthreaded Tcl */
	    const char *msg = "Tcl core wasn't compiled for threading";
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE));
	    return NULL;
	}
	Tcl_MutexUnlock(&threadMutex);
    }

    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);
    TCL_CMD(interp, THREAD_CMD_PREFIX"cancel",    ThreadCancelObjCmd);

    /*
     * Add shared variable commands
     */

    SvInit(interp);

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

    SpInit(interp);

    /*
     * Add threadpool commands.
     */

    TpoolInit(interp);

    return PACKAGE_VERSION
	    "+" STRINGIFY(THREAD_VERSION_UUID)
#if defined(__clang__) && defined(__clang_major__)
	    ".clang-" STRINGIFY(__clang_major__)
#if __clang_minor__ < 10
	    "0"
#endif
	    STRINGIFY(__clang_minor__)
#endif
#if defined(__cplusplus) && !defined(__OBJC__)
	    ".cplusplus"
#endif
#ifndef NDEBUG
	    ".debug"
#endif
#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__)
	    ".gcc-" STRINGIFY(__GNUC__)
#if __GNUC_MINOR__ < 10
	    "0"
#endif
	    STRINGIFY(__GNUC_MINOR__)
#endif
#ifdef __INTEL_COMPILER
	    ".icc-" STRINGIFY(__INTEL_COMPILER)
#endif
#ifdef HAVE_GDBM
	    ".gdbm"
#endif
#ifdef HAVE_LMDB
	    ".lmdb"
#endif
#ifdef TCL_MEM_DEBUG
	    ".memdebug"
#endif
#if defined(_MSC_VER)
	    ".msvc-" STRINGIFY(_MSC_VER)
#endif
#ifdef USE_NMAKE
	    ".nmake"
#endif
#ifndef TCL_CFG_OPTIMIZED
	    ".no-optimize"
#endif
#ifdef __OBJC__
	    ".objective-c"
#if defined(__cplusplus)
	    "plusplus"
#endif
#endif
#ifdef TCL_CFG_PROFILED
	    ".profile"
#endif
#ifdef PURIFY
	    ".purify"
#endif
#ifdef STATIC_BUILD
	    ".static"
#endif
	    ;
}

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

DLLEXPORT int
Thread_Init(
    Tcl_Interp *interp /* The current Tcl interpreter */
) {
    const char *version = ThreadInit(interp);
    Tcl_CmdInfo info;

    if (version == NULL) {
	return TCL_ERROR;
    }

    if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
#if TCL_MAJOR_VERSION > 8
	if (info.isNativeObjectProc == 2) {
	    Tcl_CreateObjCommand2(interp, "::thread::build-info",
		    info.objProc2, (void *)version, NULL);
	} else
#endif
	Tcl_CreateObjCommand(interp, "::thread::build-info",
		info.objProc, (void *)version, NULL);
    }
    Tcl_PkgProvideEx(interp, "Thread", PACKAGE_VERSION, NULL);
    return Tcl_PkgProvideEx(interp, "thread", PACKAGE_VERSION, NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    Tcl_Interp *interp         /* Current interpreter. */
) {
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->interp == NULL) {
	Tcl_Interp *tmpInterp, *mainInterp = interp;
	memset(tsdPtr, 0, sizeof(ThreadSpecificData));
	/*
	 * Retrieve main interpreter of the thread, only
	 * main interpreter used as default thread-interpreter,
	 * so no childs here, see bug [d4ba38d00d06ebba]
	 */
	while (mainInterp && (tmpInterp = Tcl_GetMaster(mainInterp))) {
	    mainInterp = tmpInterp;
	}
	tsdPtr->interp = mainInterp;
	ListUpdate(tsdPtr);
	Tcl_CreateThreadExitHandler(ThreadExitProc,
				    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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    Tcl_Size argc;
    int 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_GetString(objv[argc]);
	if (OPT_CMP(arg, "--")) {
	    argc++;
	    if ((argc + 1) == objc) {
		script = Tcl_GetString(objv[argc]);
	    } 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_GetString(objv[argc]);
	} 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. See the user documentation for
 *  details on it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    int wait = 0;
    Tcl_ThreadId thrId = NULL;

    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 (objc > 2) {
		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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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 GUARANTEED to cause memory leaks.  Use this with caution.
 *
 * Results:
 *  Doesn't actually return.
 *
 * Side effects:
 *  Lots.  improper clean up of resources.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExitObjCmd(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    int status = 666;

    Init(interp);

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?status?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	if (Tcl_GetIntFromObj(interp, objv[1], &status) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    ListRemove(NULL);

    Tcl_ExitThread(status);

    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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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, TCL_INDEX_NONE));

    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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    Tcl_Size 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(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 void
threadSendFree(void *ptr)
{
    Tcl_Free(ptr);
}

static void
threadSendObjFree(void *ptr)
{
    Tcl_DecrRefCount((Tcl_Obj *)ptr);
}

static int
ThreadSendObjCmd(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    Tcl_Size size, ii = 0;
    int cmd = 0, ret, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg;
    Tcl_Obj *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_GetString(objv[ii]);
	if (OPT_CMP(arg, "-async")) {
	    flags &= ~THREAD_SEND_WAIT;
	} else if (OPT_CMP(arg, "-head")) {
	    flags |= THREAD_SEND_HEAD;
	} else if (OPT_CMP(arg, "-command")) {
	    flags &= ~THREAD_SEND_WAIT;
	    cmd = 1;
	} 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], &size);
    size++;
    if (++ii < objc) {
	var = objv[ii];
    }
    if (var && (flags & THREAD_SEND_WAIT) == 0) {

	if (thrId == Tcl_GetCurrentThread()) {
	    /*
	     * FIXME: Do something for callbacks to self
	     */
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_INDEX_NONE));
	    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));
	if (cmd) {
	    clbkPtr->execProc   = ThreadClbkCommand;
	} else {
	    clbkPtr->execProc   = ThreadClbkSetVar;
	}
	clbkPtr->freeProc   = threadSendObjFree;
	clbkPtr->interp     = interp;
	clbkPtr->threadId   = Tcl_GetCurrentThread();
	clbkPtr->clientData = Sv_DuplicateObj(var);
	Tcl_IncrRefCount((Tcl_Obj *)clbkPtr->clientData);
    }

    /*
     * 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;
    sendPtr->clientData = memcpy(Tcl_Alloc(size), script, (size_t)size);

    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_ObjSetVar2(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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    int ii, nthreads;
    Tcl_Size size;
    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], &size);
    ++size;

    /*
     * 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;
    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 = memcpy(Tcl_Alloc(size), script, (size_t)size);
	ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD);
    }

    Tcl_Free(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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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(interp);
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    Tcl_Size 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_SetObjResult(interp, Tcl_NewStringObj(errorProcString, TCL_INDEX_NONE));
	}
    } else {
	if (errorProcString) {
	    Tcl_Free(errorProcString);
	}
	proc = Tcl_GetStringFromObj(objv[1], &len);
	if (len == 0) {
	    errorThreadId = NULL;
	    errorProcString = NULL;
	} else {
	    errorThreadId = Tcl_GetCurrentThread();
	    errorProcString = (char *)Tcl_Alloc(1+strlen(proc));
	    strcpy(errorProcString, proc);
	    Tcl_DeleteThreadExitHandler(ThreadFreeError, NULL);
	    Tcl_CreateThreadExitHandler(ThreadFreeError, NULL);
	}
    }
    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

static void
ThreadFreeError(
    TCL_UNUSED(void *)
) {
    Tcl_MutexLock(&threadMutex);
    if (errorThreadId != Tcl_GetCurrentThread()) {
	Tcl_MutexUnlock(&threadMutex);
	return;
    }
    Tcl_Free(errorProcString);
    errorThreadId = NULL;
    errorProcString = NULL;
    Tcl_MutexUnlock(&threadMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    TCL_UNUSED(void *),         /* Not used. */
    Tcl_Interp *interp,         /* Current interpreter. */
    Tcl_Size    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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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 == 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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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 == 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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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_SetIntObj(Tcl_GetObjResult(interp), ThreadExists(thrId)!=0);

    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(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    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;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadCancelObjCmd --
 *
 *  This procedure is invoked to process the "thread::cancel" 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
ThreadCancelObjCmd(
    TCL_UNUSED(void *),        /* Not used. */
    Tcl_Interp *interp,        /* Current interpreter. */
    Tcl_Size    objc,          /* Number of arguments. */
    Tcl_Obj    *const objv[]   /* Argument objects. */
) {
    Tcl_ThreadId thrId;
    int ii, flags;
    const char *result;

    if ((objc < 2) || (objc > 4)) {
	Tcl_WrongNumArgs(interp, 1, objv, "?-unwind? id ?result?");
	return TCL_ERROR;
    }

    flags = 0;
    ii = 1;
    if ((objc == 3) || (objc == 4)) {
	if (OPT_CMP(Tcl_GetString(objv[ii]), "-unwind")) {
	    flags |= TCL_CANCEL_UNWIND;
	    ii++;
	}
    }

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

    ii++;
    if (ii < objc) {
	result = Tcl_GetString(objv[ii]);
    } else {
	result = NULL;
    }

    return ThreadCancel(interp, thrId, result, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSendEval --
 *
 *  Evaluates Tcl script passed from source to target thread.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

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

    return Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 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(
    Tcl_Interp *interp,
    void *clientData
) {
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    Tcl_Obj *var = (Tcl_Obj *)clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;
    int rc = TCL_OK;

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

    valObj = Tcl_NewStringObj(resultPtr->result, -1);
    Tcl_IncrRefCount(valObj);

    if (resultPtr->result != threadEmptyResult) {
	Tcl_Free(resultPtr->result);
    }

    /*
     * Set the result variable
     */

    if (Tcl_ObjSetVar2(interp, var, NULL, valObj,
	    TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
	rc = TCL_ERROR;
	goto cleanup;
    }

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

    if (resultPtr->code == TCL_ERROR) {
	if (resultPtr->errorCode) {
	    Tcl_SetVar2Ex(interp, "errorCode", NULL,
		Tcl_NewStringObj(resultPtr->errorCode, TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
	    Tcl_Free(resultPtr->errorCode);
	}
	if (resultPtr->errorInfo) {
	    Tcl_SetVar2Ex(interp, "errorInfo", NULL,
		Tcl_NewStringObj(resultPtr->errorInfo, TCL_INDEX_NONE), TCL_GLOBAL_ONLY);
	    Tcl_Free(resultPtr->errorInfo);
	}
	Tcl_SetObjResult(interp, valObj);
	Tcl_BackgroundException(interp, TCL_ERROR);
	return TCL_ERROR;
    }
    return TCL_OK;

cleanup:
    Tcl_DecrRefCount(valObj);
    return rc;
}

static int ThreadClbkCommand(Tcl_Interp *interp, void *clientData)
{
    int status = TCL_OK;
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    Tcl_Obj *script = (Tcl_Obj *)clbkPtr->clientData;
    ThreadEventResult *resultPtr = &clbkPtr->result;

    if (resultPtr->code == TCL_ERROR) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, TCL_INDEX_NONE));
	Tcl_BackgroundError(interp);
	goto cleanup;
    }

    if ((status = Tcl_ListObjAppendElement(
	interp, script, Tcl_NewStringObj(resultPtr->result, TCL_INDEX_NONE))) != TCL_OK) {
	goto cleanup;
    }
    status = Tcl_GlobalEvalObj(interp, script);

cleanup:
    Tcl_Free(resultPtr->result);
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    Tcl_Interp *interp,        /* Current interpreter. */
    const char *script,        /* Script to evaluate */
    TCL_HASH_TYPE 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;

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

    Tcl_MutexLock(&threadMutex);
    if (Tcl_CreateThread(&thrId, NewThread, &ctrl,
	    stacksize, flags) != TCL_OK) {
	Tcl_MutexUnlock(&threadMutex);
	Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_INDEX_NONE));
	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 == 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, TCL_INDEX_NONE));

    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(
    void *clientData
) {
    ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_Interp *interp;
    int result = TCL_OK;
    size_t 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
    NsThreadInterpData *md = (NsThreadInterpData *)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, evalScript);

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

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

    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve(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(tsdPtr->interp);

    /*tsdPtr->interp = NULL;*/

    /*
     * 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(
    Tcl_Interp *interp         /* Interp that failed */
) {
    ThreadSendData *sendPtr;
    const char *argv[3];
    char buf[THREAD_HNDLMAXLEN];
    const char *errorInfo;

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

    if (errorProcString == NULL) {
#ifdef NS_AOLSERVER
	Ns_Log(Error, "%s\n%s", Tcl_GetString(Tcl_GetObjResult(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 ", TCL_INDEX_NONE);
	Tcl_WriteChars(errChannel, buf, TCL_INDEX_NONE);
	Tcl_WriteChars(errChannel, "\n", 1);
	Tcl_WriteChars(errChannel, errorInfo, TCL_INDEX_NONE);
	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;
	sendPtr->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(
    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(
    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(
    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(
    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(
    TCL_UNUSED(Tcl_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) {
	Tcl_MutexUnlock(&threadMutex);
	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 whether 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(
     Tcl_ThreadId thrId
) {
    ThreadSpecificData *tsdPtr;

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

    return tsdPtr != NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadExistsInner --
 *
 *  Test whether 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(
    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;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadCancel --
 *
 *    Cancels a script in another thread.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCancel(
    Tcl_Interp  *interp,       /* The current interpreter. */
    Tcl_ThreadId thrId,        /* Thread ID of other interpreter. */
    const char *result,        /* The error message or NULL for default. */
    int flags                  /* Flags for Tcl_CancelEval. */
) {
    int code;
    Tcl_Obj *resultObj = NULL;
    ThreadSpecificData *tsdPtr; /* ... of the target thread */

    Tcl_MutexLock(&threadMutex);

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

    if (result != NULL) {
	resultObj = Tcl_NewStringObj(result, TCL_INDEX_NONE);
    }

    code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);

    Tcl_MutexUnlock(&threadMutex);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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, (void *)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(
    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_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_INDEX_NONE));
    }
    if (Tcl_IsChannelShared(chan)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_INDEX_NONE));
	return TCL_ERROR;
    }

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

    /*
     * (*) 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: ", (void *)NULL);

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

	return TCL_ERROR;
    }

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

    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(
    Tcl_Interp *interp,        /* The current interpreter. */
    Tcl_Channel chan           /* The channel to detach */
) {
    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_INDEX_NONE));
    }
    if (Tcl_IsChannelShared(chan)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_INDEX_NONE));
	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       = NULL;
    resultPtr->resultCode = -1;
    resultPtr->resultMsg  = 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 = NULL;
    resultPtr->dstThreadId = NULL;
    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(
    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", (void *)NULL);
		return TCL_ERROR;
	    }
	    SpliceOut(resPtr, transferList);
	    Tcl_Free(resPtr->eventPtr);
	    Tcl_Free(resPtr);
	    found = 1;
	    break;
	}
    }
    Tcl_MutexUnlock(&threadMutex);

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

    /*
     * Splice channel into the current interpreter
     */

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

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

static int
ThreadSend(
    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 == NULL
	    || (tsdPtr->flags & THREAD_FLAGS_INERROR)) {
	int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR);
	Tcl_MutexUnlock(&threadMutex);
	ThreadFreeProc(send);
	if (clbk) {
	    ThreadFreeProc(clbk);
	}
	if (inerror) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", TCL_INDEX_NONE));
	} else {
	    ErrorNoSuchThread(interp, thrId);
	}
	return TCL_ERROR;
    }

    /*
     * Short circuit sends to ourself (synchronously only).
     */

    if (thrId == Tcl_GetCurrentThread() && (flags & THREAD_SEND_WAIT)) {
	Tcl_MutexUnlock(&threadMutex);

	if (!(flags & THREAD_SEND_HEAD)) {
	    /*
	     * Be sure all already queued events are processed before this event
	     */
	    while ( Tcl_DoOneEvent((TCL_ALL_EVENTS & ~TCL_IDLE_EVENTS)|TCL_DONT_WAIT) ) {};
	}
	/* call it synchronously right now */
	code = (*send->execProc)(interp, send);
	ThreadFreeProc(send);
	return code;
    }

    /*
     * 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(eventPtr->clbkData->interp);
    }
    if ((flags & THREAD_SEND_WAIT) == 0) {
	resultPtr              = NULL;
	eventPtr->resultPtr    = NULL;
    } else {
	resultPtr = (ThreadEventResult *)Tcl_Alloc(sizeof(ThreadEventResult));
	resultPtr->done        = 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|TCL_QUEUE_ALERT_IF_EMPTY);
    } else {
	Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
    }

    if ((flags & THREAD_SEND_WAIT) == 0) {
	/*
	 * Might potentially spend some time here, until the
	 * worker thread cleans up its queue a little bit.
	 */
	if ((flags & THREAD_SEND_CLBK) == 0) {
	    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_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_INDEX_NONE));
	    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(resultPtr);

    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadWait --
 *
 *  Waits for events and process them as they come, until signaled
 *  to stop.
 *
 * Results:
 *  Standard Tcl result.
 *
 * Side effects:
 *  Deletes any thread::send or thread::transfer events that are
 *  pending.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadWait(Tcl_Interp *interp)
{
    int code = TCL_OK;
    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);
	}

	/*
	 * Attempt to process one event, blocking forever until an
	 * event is actually received.  The event processed may cause
	 * a script in progress to be canceled or exceed its limit;
	 * therefore, check for these conditions if we are able to
	 * (i.e. we are running in a high enough version of Tcl).
	 */

	Tcl_DoOneEvent(TCL_ALL_EVENTS);

	/*
	 * If the script has been unwound, bail out immediately. This does
	 * not follow the recommended guidelines for how extensions should
	 * handle the script cancellation functionality because this is
	 * not a "normal" extension. Most extensions do not have a command
	 * that simply enters an infinite Tcl event loop. Normal extensions
	 * should not specify the TCL_CANCEL_UNWIND when calling the
	 * Tcl_Canceled function to check if the command has been canceled.
	 */

	if (Tcl_Canceled(tsdPtr->interp,
		TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
	    code = TCL_ERROR;
	    break;
	}
	if (Tcl_LimitExceeded(tsdPtr->interp)) {
	    code = TCL_ERROR;
	    break;
	}

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

    /*
     * If the event processing loop above was terminated due to a
     * script in progress being canceled or exceeding its limits,
     * transfer the error to the current interpreter.
     */

    if (code != TCL_OK) {
	char buf[THREAD_HNDLMAXLEN];
	const char *errorInfo;

	errorInfo = Tcl_GetVar2(tsdPtr->interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
	if (errorInfo == NULL) {
	    errorInfo = Tcl_GetString(Tcl_GetObjResult(tsdPtr->interp));
	}

	ThreadGetHandle(Tcl_GetCurrentThread(), buf);
	Tcl_AppendResult(interp, "Error from thread ", buf, "\n",
		errorInfo, (void *)NULL);
    }

    /*
     * 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 code;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadReserve --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReserve(
    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 == NULL) {
	tsdPtr = TCL_TSD_INIT(&dataKey);
    } else {
	tsdPtr = ThreadExistsInner(thrId);
	if (tsdPtr == 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 && thrId != Tcl_GetCurrentThread() /* 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        = 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_QUEUE_ALERT_IF_EMPTY);

	    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(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(
    Tcl_Event *evPtr,          /* Really ThreadEvent */
    TCL_UNUSED(int)
) {
    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 whether user has any preferences about which interpreter
     * to use for running this job. The job structure might identify
     * 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
     * async 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) {
	Tcl_Preserve(interp);

	if (clbkPtr && clbkPtr->threadId == thrId) {
	    Tcl_Release(interp);
	    /* Watch: this thread evaluates its own callback. */
	    interp = clbkPtr->interp;
	    Tcl_Preserve(interp);
	}

	Tcl_ResetResult(interp);

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

    if (sendPtr) {
	ThreadFreeProc(sendPtr);
	eventPtr->sendData = NULL;
    }

    if (resultPtr) {

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

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

	/*
	 * We still need to release the reference to the Tcl
	 * interpreter added by ThreadSend whenever the callback
	 * data is not NULL.
	 */

	if (clbkPtr) {
	    Tcl_Release(clbkPtr->interp);
	}
    } 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_OK) {
	    ThreadErrorProc(interp);
	}

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

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

	/*
	 * We still need to release the reference to the Tcl
	 * interpreter added by ThreadSend whenever the callback
	 * data is not NULL.
	 */

	if (clbkPtr) {
	    Tcl_Release(clbkPtr->interp);
	}
    } else {
	/*
	 * We still need to release the reference to the Tcl
	 * interpreter added by ThreadSend whenever the callback
	 * data is not NULL.
	 */

	if (clbkPtr) {
	    Tcl_Release(clbkPtr->interp);
	}
    }

    if (interp != NULL) {
	Tcl_Release(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(
    Tcl_Interp *interp,
    int code,
    ThreadEventResult *resultPtr
) {
    const char *errorCode, *errorInfo, *result;
    size_t size;

    if (interp == NULL) {
	code      = TCL_ERROR;
	errorInfo = "";
	errorCode = "THREAD";
	result    = "no target interp!";
	size    = strlen(result);
	resultPtr->result = (size) ?
	    memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult;
    } else {
	result = Tcl_GetString(Tcl_GetObjResult(interp));
	size = Tcl_GetObjResult(interp)->length;
	resultPtr->result = (size) ?
		memcpy(Tcl_Alloc(1+size), result, 1+size) : threadEmptyResult;
	if (code == TCL_ERROR) {
	    errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
	    errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
	} else {
	    errorCode = NULL;
	    errorInfo = NULL;
	}
    }

    resultPtr->code = code;

    if (errorCode != NULL) {
	size = strlen(errorCode) + 1;
	resultPtr->errorCode = (char *)memcpy(Tcl_Alloc(size), errorCode, size);
    } else {
	resultPtr->errorCode = NULL;
    }
    if (errorInfo != NULL) {
	size = strlen(errorInfo) + 1;
	resultPtr->errorInfo = (char *)memcpy(Tcl_Alloc(size), errorInfo, size);
    } else {
	resultPtr->errorInfo = NULL;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadGetOption --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadGetOption(
    Tcl_Interp *interp,
    Tcl_ThreadId thrId,
    char *option,
    Tcl_DString *dsPtr
) {
    size_t 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 == 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");
	}
	snprintf(buf, sizeof(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", (void *)NULL);
	Tcl_MutexUnlock(&threadMutex);
	return TCL_ERROR;
    }

    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSetOption --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

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

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);

    if (tsdPtr == 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, "\"", (void *)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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    Tcl_Event *evPtr,          /* Really ThreadEvent */
    TCL_UNUSED(int)
) {
    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) {
	    size_t size = strlen(msg)+1;
	    resultPtr->resultMsg = (char *)memcpy(Tcl_Alloc(size), msg, size);
	}
	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(
    void *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(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(
    Tcl_Event *eventPtr,       /* Really ThreadEvent */
    TCL_UNUSED(void *)         /* dummy */
) {
    if (eventPtr->proc == ThreadEventProc) {
	/*
	 * Regular script event. Just dispose memory
	 */
	ThreadEvent *evPtr = (ThreadEvent*)eventPtr;
	if (evPtr->sendData) {
	    ThreadFreeProc(evPtr->sendData);
	    evPtr->sendData = NULL;
	}
	if (evPtr->clbkData) {
	    ThreadFreeProc(evPtr->clbkData);
	    evPtr->clbkData = NULL;
	}
	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(
    void *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(threadEvalScript);
    }

    Tcl_MutexLock(&threadMutex);

    /*
     * NaviServer/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(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(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((char *)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(
    Tcl_ThreadId thrId,
    char *handlePtr
) {
    snprintf(handlePtr, THREAD_HNDLMAXLEN, THREAD_HNDLPREFIX "%p", thrId);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadGetId --
 *
 *  Returns the ID of thread given it's Tcl handle.
 *
 * Results:
 *  Thread ID.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

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

    Tcl_AppendResult(interp, "invalid thread handle \"",
		     thrHandle, "\"", (void *)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(
    Tcl_Interp *interp,
    Tcl_ThreadId thrId
) {
    char thrHandle[THREAD_HNDLMAXLEN];

    ThreadGetHandle(thrId, thrHandle);
    Tcl_AppendResult(interp, "thread \"", thrHandle,
		     "\" does not exist", (void *)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(
    Tcl_Interp *interp,
    Tcl_Channel chan
) {
    Tcl_DriverWatchProc *watchProc;

    Tcl_ClearChannelHandlers(chan);

    watchProc   = Tcl_ChannelWatchProc(Tcl_GetChannelType(chan));

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