Tcl package Thread source code

#define _TCL_THREAD_H_

#include <tcl.h>

/*
 * Exported from threadCmd.c file.
 */



DLLEXPORT int Thread_Init(Tcl_Interp *interp);




#endif /* _TCL_THREAD_H_ */

/*
 * Macro that behaves like strdup, only uses Tcl_Alloc.  Also macro that does the
 * same with a string that might contain zero bytes,
 */

#define ckstrdup(sourceStr) \
  strcpy (Tcl_Alloc(strlen (sourceStr) + 1), sourceStr)

#define ckbinstrdup(sourceStr, length) \
  memcpy(Tcl_Alloc(length + 1), sourceStr, length + 1)

/*
 * Used to return argument messages by most commands.
 */
static const char *tclXWrongArgs = "wrong # args: ";

static const Tcl_ObjType *listType;

 * Parameters:
 *   o objPtr - Object to check.
 * Returns:
 *   1 if NULL, 0 if not.
 *-----------------------------------------------------------------------------
 */
static int
TclX_IsNullObj (objPtr)
    Tcl_Obj *objPtr;
{

    if (objPtr->typePtr == NULL) {
        return (objPtr->length == 0);
    } else if (objPtr->typePtr == listType) {
        int length;
        Tcl_ListObjLength(NULL, objPtr, &length);
        return (length == 0);
    }

 *   o commandNameObj - Object containing name of command (objv[0])
 *   o string - Text message to append.
 * Returns:
 *   TCL_ERROR
 *-----------------------------------------------------------------------------
 */
static int
TclX_WrongArgs (interp, commandNameObj, string)
    Tcl_Interp  *interp;
    Tcl_Obj     *commandNameObj;
    char        *string;
{

    const char *commandName = Tcl_GetString(commandNameObj);
    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

    Tcl_ResetResult(interp);
    Tcl_AppendStringsToObj (resultPtr,
                            tclXWrongArgs,
                            commandName,
                            (char *)NULL);

    if (*string != '\0') {
        Tcl_AppendStringsToObj (resultPtr, " ", string, (char *)NULL);
    }
    return TCL_ERROR;
}

/*---------------------------------------------------------------------------*/
/*---------------------------------------------------------------------------*/
/*                    Here is where the original file begins                 */

SetKeyedListFromAny(Tcl_Interp *interp,
                                 Tcl_Obj    *objPtr);

static void
UpdateStringOfKeyedList(Tcl_Obj *keylPtr);

static int
Tcl_KeylgetObjCmd(void *       clientData,






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

static int
Tcl_KeylsetObjCmd(void *       clientData,
                               Tcl_Interp  *interp,
                               int  objc,
                               Tcl_Obj     *const objv[]);

static int
Tcl_KeyldelObjCmd(void *       clientData,
                               Tcl_Interp  *interp,
                               int  objc,
                               Tcl_Obj     *const objv[]);

static int
Tcl_KeylkeysObjCmd(void *       clientData,
                                Tcl_Interp  *interp,
                                int  objc,
                                Tcl_Obj     *const objv[]);

/*
 * Type definition.
 */

 *   o isPath - 1 if this is a key path, 0 if its a simple key and
 *     thus "." is illegal.
 * Returns:
 *    TCL_OK or TCL_ERROR.
 *-----------------------------------------------------------------------------
 */
static int
ValidateKey(interp, key, keyLen, isPath)
    Tcl_Interp *interp;
    const char *key;
    size_t keyLen;
    int isPath;
{

    const char *keyp;

    if (strlen(key) != keyLen) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                                "keyed list key may not be a ",
                                "binary string", (char *) NULL);

 *   Allocate an and initialize the keyed list internal representation.
 *
 * Returns:
 *    A pointer to the keyed list internal structure.
 *-----------------------------------------------------------------------------
 */
static keylIntObj_t *
AllocKeyedListIntRep ()
{
    keylIntObj_t *keylIntPtr;

    keylIntPtr = Tcl_Alloc(sizeof(keylIntObj_t));

    keylIntPtr->arraySize = 0;
    keylIntPtr->numEntries = 0;
    keylIntPtr->entries = NULL;

    return keylIntPtr;
}

/*-----------------------------------------------------------------------------
 * FreeKeyedListData --
 *   Free the internal representation of a keyed list.
 *
 * Parameters:
 *   o keylIntPtr - Keyed list internal structure to free.
 *-----------------------------------------------------------------------------
 */
static void
FreeKeyedListData (keylIntPtr)
    keylIntObj_t *keylIntPtr;
{

    int idx;

    for (idx = 0; idx < keylIntPtr->numEntries ; idx++) {
        Tcl_Free(keylIntPtr->entries[idx].key);
        Tcl_DecrRefCount (keylIntPtr->entries[idx].valuePtr);
    }
    if (keylIntPtr->entries != NULL)

 * Parameters:
 *   o keylIntPtr - Keyed list internal representation.
 *   o newNumEntries - The number of entries that are going to be added to
 *     the keyed list.
 *-----------------------------------------------------------------------------
 */
static void
EnsureKeyedListSpace (keylIntPtr, newNumEntries)
    keylIntObj_t *keylIntPtr;
    int           newNumEntries;
{

    KEYL_REP_ASSERT (keylIntPtr);

    if ((keylIntPtr->arraySize - keylIntPtr->numEntries) < newNumEntries) {
        int newSize = keylIntPtr->arraySize + newNumEntries +
            KEYEDLIST_ARRAY_INCR_SIZE;
        if (keylIntPtr->entries == NULL) {
            keylIntPtr->entries =
                Tcl_Alloc(newSize * sizeof(keylEntry_t));
        } else {
            keylIntPtr->entries =
                Tcl_Realloc(keylIntPtr->entries,
                           newSize * sizeof(keylEntry_t));
        }
        keylIntPtr->arraySize = newSize;
    }

    KEYL_REP_ASSERT (keylIntPtr);
}

/*-----------------------------------------------------------------------------
 * DeleteKeyedListEntry --
 *   Delete an entry from a keyed list.
 *
 * Parameters:
 *   o keylIntPtr - Keyed list internal representation.
 *   o entryIdx - Index of entry to delete.
 *-----------------------------------------------------------------------------
 */
static void
DeleteKeyedListEntry (keylIntPtr, entryIdx)
    keylIntObj_t *keylIntPtr;
    int           entryIdx;
{

    int idx;

    Tcl_Free(keylIntPtr->entries [entryIdx].key);
    Tcl_DecrRefCount (keylIntPtr->entries [entryIdx].valuePtr);

    for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++)
        keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1];

 *   o nextSubKeyPtr - If not NULL, the start of the name of the next
 *     sub-key within key is returned.
 * Returns:
 *   Index of the entry or -1 if not found.
 *-----------------------------------------------------------------------------
 */
static int
FindKeyedListEntry (keylIntPtr, key, keyLenPtr, nextSubKeyPtr)
    keylIntObj_t *keylIntPtr;
    const char   *key;
    size_t       *keyLenPtr;
    const char   **nextSubKeyPtr;
{

    char *keySeparPtr;
    size_t keyLen;
    int findIdx;

    keySeparPtr = strchr (key, '.');
    if (keySeparPtr != NULL) {
        keyLen = keySeparPtr - key;

 *     value.
 *   o entryPtr - The keyed list entry to initialize from the object.
 * Returns:
 *    TCL_OK or TCL_ERROR.
 *-----------------------------------------------------------------------------
 */
static int
ObjToKeyedListEntry (interp, objPtr, entryPtr)
    Tcl_Interp  *interp;
    Tcl_Obj     *objPtr;
    keylEntry_t *entryPtr;
{

    int objc;
    Tcl_Obj **objv;
    const char *key;

    if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
        Tcl_ResetResult (interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult (interp),

 *   Free the internal representation of a keyed list.
 *
 * Parameters:
 *   o keylPtr - Keyed list object being deleted.
 *-----------------------------------------------------------------------------
 */
static void
FreeKeyedListInternalRep (keylPtr)
    Tcl_Obj *keylPtr;
{

    FreeKeyedListData(keylPtr->internalRep.twoPtrValue.ptr1);
}

/*-----------------------------------------------------------------------------
 * DupKeyedListInternalRep --
 *   Duplicate the internal representation of a keyed list.
 *
 * Parameters:
 *   o srcPtr - Keyed list object to copy.
 *   o copyPtr - Target object to copy internal representation to.
 *-----------------------------------------------------------------------------
 */
static void
DupKeyedListInternalRep (srcPtr, copyPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *copyPtr;
{

    keylIntObj_t *srcIntPtr =
        srcPtr->internalRep.twoPtrValue.ptr1;
    keylIntObj_t *copyIntPtr;
    int idx;

    KEYL_REP_ASSERT (srcIntPtr);

    copyIntPtr = Tcl_Alloc(sizeof(keylIntObj_t));
    copyIntPtr->arraySize = srcIntPtr->arraySize;
    copyIntPtr->numEntries = srcIntPtr->numEntries;
    copyIntPtr->entries =
        Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t));

    for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
        copyIntPtr->entries [idx].key =
            ckstrdup (srcIntPtr->entries [idx].key);
        copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr;
        Tcl_IncrRefCount (copyIntPtr->entries [idx].valuePtr);

 *
 * Parameters:
 *   o srcPtr - Keyed list object to copy.
 *   o copyPtr - Target object to copy internal representation to.
 *-----------------------------------------------------------------------------
 */
void
DupKeyedListInternalRepShared (srcPtr, copyPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *copyPtr;
{

    keylIntObj_t *srcIntPtr =
        srcPtr->internalRep.twoPtrValue.ptr1;
    keylIntObj_t *copyIntPtr;
    int idx;

    KEYL_REP_ASSERT (srcIntPtr);

    copyIntPtr = Tcl_Alloc(sizeof(keylIntObj_t));
    copyIntPtr->arraySize = srcIntPtr->arraySize;
    copyIntPtr->numEntries = srcIntPtr->numEntries;
    copyIntPtr->entries =
        Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t));

    for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
        copyIntPtr->entries [idx].key =
            ckstrdup (srcIntPtr->entries [idx].key);
        copyIntPtr->entries [idx].valuePtr =
            Sv_DuplicateObj (srcIntPtr->entries [idx].valuePtr);

 * the keyed list recurses until lower levels are accessed.
 *
 * Parameters:
 *   o objPtr - Object to convert to a keyed list.
 *-----------------------------------------------------------------------------
 */
static int
SetKeyedListFromAny (interp, objPtr)
    Tcl_Interp *interp;
    Tcl_Obj    *objPtr;
{

    keylIntObj_t *keylIntPtr;
    int idx;
    int objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK)
        return TCL_ERROR;

 *    Update the string representation of a keyed list.
 *
 * Parameters:
 *   o objPtr - Object to convert to a keyed list.
 *-----------------------------------------------------------------------------
 */
static void
UpdateStringOfKeyedList (keylPtr)
    Tcl_Obj  *keylPtr;
{

#define UPDATE_STATIC_SIZE 32
    int idx;
    Tcl_Obj **listObjv, *entryObjv [2], *tmpListObj;
    Tcl_Obj *staticListObjv [UPDATE_STATIC_SIZE];
    char *listStr;
    keylIntObj_t *keylIntPtr =
        keylPtr->internalRep.twoPtrValue.ptr1;

    /*
     * Conversion to strings is done via list objects to support binary data.
     */
    if (keylIntPtr->numEntries > UPDATE_STATIC_SIZE) {
        listObjv =
            Tcl_Alloc(keylIntPtr->numEntries * sizeof(Tcl_Obj *));
    } else {
        listObjv = staticListObjv;
    }

    /*
     * Convert each keyed list entry to a two element list object.  No

 *   Create and initialize a new keyed list object.
 *
 * Returns:
 *    A pointer to the object.
 *-----------------------------------------------------------------------------
 */
Tcl_Obj *
TclX_NewKeyedListObj ()
{
    Tcl_Obj *keylPtr = Tcl_NewObj ();
    keylIntObj_t *keylIntPtr = AllocKeyedListIntRep ();

    keylPtr->internalRep.twoPtrValue.ptr1 = keylIntPtr;
    keylPtr->typePtr = &keyedListType;
    return keylPtr;

 * Returns:
 *   o TCL_OK - If the key value was returned.
 *   o TCL_BREAK - If the key was not found.
 *   o TCL_ERROR - If an error occured.
 *-----------------------------------------------------------------------------
 */
int
TclX_KeyedListGet (interp, keylPtr, key, valuePtrPtr)
    Tcl_Interp *interp;
    Tcl_Obj    *keylPtr;
    const char *key;
    Tcl_Obj   **valuePtrPtr;
{

    keylIntObj_t *keylIntPtr;
    const char *nextSubKey;
    int findIdx;

    if (keylPtr->typePtr != &keyedListType) {
        if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    }
    keylIntPtr = keylPtr->internalRep.twoPtrValue.ptr1;
    KEYL_REP_ASSERT (keylIntPtr);

    findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey);

    /*
     * If not found, return status.
     */

 *     sub-key seperated by `.'.
 *   o valueObjPtr - The value to set for the key.
 * Returns:
 *   TCL_OK or TCL_ERROR.
 *-----------------------------------------------------------------------------
 */
int
TclX_KeyedListSet (interp, keylPtr, key, valuePtr)
    Tcl_Interp *interp;
    Tcl_Obj    *keylPtr;
    const char *key;
    Tcl_Obj    *valuePtr;
{

    keylIntObj_t *keylIntPtr;
    const char *nextSubKey;
    int findIdx, status;
    size_t keyLen;
    Tcl_Obj *newKeylPtr;

    if (keylPtr->typePtr != &keyedListType) {
        if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    }
    keylIntPtr = keylPtr->internalRep.twoPtrValue.ptr1;
    KEYL_REP_ASSERT (keylIntPtr);

    findIdx = FindKeyedListEntry (keylIntPtr, key,
                                  &keyLen, &nextSubKey);

    /*
     * If we are at the last subkey, either update or add an entry.
     */
    if (nextSubKey == NULL) {
        if (findIdx < 0) {
            EnsureKeyedListSpace (keylIntPtr, 1);
            findIdx = keylIntPtr->numEntries;
            keylIntPtr->numEntries++;
        } else {
            Tcl_Free(keylIntPtr->entries [findIdx].key);
            Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr);
        }
        keylIntPtr->entries [findIdx].key =
            Tcl_Alloc(keyLen + 1);
        strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
        keylIntPtr->entries [findIdx].key [keyLen] = '\0';
        keylIntPtr->entries [findIdx].valuePtr = valuePtr;
        Tcl_IncrRefCount (valuePtr);
        Tcl_InvalidateStringRep (keylPtr);

        if (TclX_KeyedListSet (interp, newKeylPtr,
                               nextSubKey, valuePtr) != TCL_OK) {
            Tcl_DecrRefCount (newKeylPtr);
            return TCL_ERROR;
        }
        EnsureKeyedListSpace (keylIntPtr, 1);
        findIdx = keylIntPtr->numEntries++;
        keylIntPtr->entries [findIdx].key =
            Tcl_Alloc(keyLen + 1);
        strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
        keylIntPtr->entries [findIdx].key [keyLen] = '\0';
        keylIntPtr->entries [findIdx].valuePtr = newKeylPtr;
        Tcl_IncrRefCount (newKeylPtr);
        Tcl_InvalidateStringRep (keylPtr);

 * Returns:
 *   o TCL_OK - If the key was deleted.
 *   o TCL_BREAK - If the key was not found.
 *   o TCL_ERROR - If an error occured.
 *-----------------------------------------------------------------------------
 */
int
TclX_KeyedListDelete (interp, keylPtr, key)
    Tcl_Interp *interp;
    Tcl_Obj    *keylPtr;
    const char *key;
{

    keylIntObj_t *keylIntPtr, *subKeylIntPtr;
    const char *nextSubKey;
    int findIdx, status;

    if (keylPtr->typePtr != &keyedListType) {
        if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    }
    keylIntPtr = keylPtr->internalRep.twoPtrValue.ptr1;

    findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey);

    /*
     * If not found, return status.
     */
    if (findIdx < 0) {

     */
    DupSharedKeyListChild (keylIntPtr, findIdx);

    status = TclX_KeyedListDelete (interp,
                                   keylIntPtr->entries [findIdx].valuePtr,
                                   nextSubKey);
    if (status == TCL_OK) {
        subKeylIntPtr =
            keylIntPtr->entries [findIdx].valuePtr->internalRep.twoPtrValue.ptr1;
        if (subKeylIntPtr->numEntries == 0) {
            DeleteKeyedListEntry (keylIntPtr, findIdx);
        }
        Tcl_InvalidateStringRep (keylPtr);
    }

 * Returns:
 *   o TCL_OK - If the zero or more key where returned.
 *   o TCL_BREAK - If the key was not found.
 *   o TCL_ERROR - If an error occured.
 *-----------------------------------------------------------------------------
 */
int
TclX_KeyedListGetKeys (interp, keylPtr, key, listObjPtrPtr)
    Tcl_Interp *interp;
    Tcl_Obj    *keylPtr;
    const char *key;
    Tcl_Obj   **listObjPtrPtr;
{

    keylIntObj_t *keylIntPtr;
    Tcl_Obj *nameObjPtr, *listObjPtr;
    const char *nextSubKey;
    int idx, findIdx;

    if (keylPtr->typePtr != &keyedListType) {
        if (SetKeyedListFromAny(interp, keylPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    }
    keylIntPtr = keylPtr->internalRep.twoPtrValue.ptr1;

    /*
     * If key is not NULL or empty, then recurse down until we go past
     * the end of all of the elements of the key.
     */
    if ((key != NULL) && (key [0] != '\0')) {
        findIdx = FindKeyedListEntry (keylIntPtr, key, NULL, &nextSubKey);

/*-----------------------------------------------------------------------------
 * Tcl_KeylgetObjCmd --
 *     Implements the TCL keylget command:
 *         keylget listvar ?key? ?retvar | {}?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylgetObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{

    Tcl_Obj *keylPtr, *valuePtr;
    const char *key;
    int status;

    if ((objc < 2) || (objc > 4)) {
        return TclX_WrongArgs (interp, objv [0],
                               "listvar ?key? ?retvar | {}?");

/*-----------------------------------------------------------------------------
 * Tcl_KeylsetObjCmd --
 *     Implements the TCL keylset command:
 *         keylset listvar key value ?key value...?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylsetObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{

    Tcl_Obj *keylVarPtr, *newVarObj;
    const char *key;
    int idx;

    if ((objc < 4) || ((objc % 2) != 0)) {
        return TclX_WrongArgs (interp, objv [0],
                               "listvar key value ?key value...?");

/*-----------------------------------------------------------------------------
 * Tcl_KeyldelObjCmd --
 *     Implements the TCL keyldel command:
 *         keyldel listvar key ?key ...?
 *----------------------------------------------------------------------------
 */
static int
Tcl_KeyldelObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{

    Tcl_Obj *keylVarPtr, *keylPtr;
    const char *key;
    int idx, status;

    if (objc < 3) {
        return TclX_WrongArgs (interp, objv [0], "listvar key ?key ...?");
    }

/*-----------------------------------------------------------------------------
 * Tcl_KeylkeysObjCmd --
 *     Implements the TCL keylkeys command:
 *         keylkeys listvar ?key?
 *-----------------------------------------------------------------------------
 */
static int
Tcl_KeylkeysObjCmd (clientData, interp, objc, objv)
    void *clientData;
    Tcl_Interp  *interp;
    int  objc;
    Tcl_Obj     *const objv[];
{

    Tcl_Obj *keylPtr, *listObjPtr;
    const char *key;
    int status;

    if ((objc < 2) || (objc > 3)) {
        return TclX_WrongArgs(interp, objv [0], "listvar ?key?");
    }

 *   Initialize the keyed list commands for this interpreter.
 *
 * Parameters:
 *   o interp - Interpreter to add commands to.
 *-----------------------------------------------------------------------------
 */
void
TclX_KeyedListInit (interp)
    Tcl_Interp *interp;
{

    Tcl_Obj *listobj;

    listobj = Tcl_NewObj();
    listobj = Tcl_NewListObj(1, &listobj);
    listType = listobj->typePtr;
    Tcl_DecrRefCount(listobj);

    if (0) {
    Tcl_CreateObjCommand (interp,
                          "keylget",
                          Tcl_KeylgetObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keylset",
                          Tcl_KeylsetObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keyldel",
                          Tcl_KeyldelObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);

    Tcl_CreateObjCommand (interp,
                          "keylkeys",
                          Tcl_KeylkeysObjCmd,
                          NULL,
                          (Tcl_CmdDeleteProc*) NULL);
    }
}

static Tcl_ObjCmdProc ThreadJoinObjCmd;
static Tcl_ObjCmdProc ThreadTransferObjCmd;
static Tcl_ObjCmdProc ThreadDetachObjCmd;
static Tcl_ObjCmdProc ThreadAttachObjCmd;
static Tcl_ObjCmdProc ThreadCancelObjCmd;

static int
ThreadInit(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{

    /* Tcl 8.6 interps are only supported on 32-bit machines.
     * Lower than that is never supported. Bye!
     */
    const char *ver = (sizeof(size_t) == sizeof(int))? "8.6-": "9.0";

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

 * Side effects:
 *  Adds package commands to the current interp.
 *
 *----------------------------------------------------------------------
 */

DLLEXPORT int
Thread_Init(interp)
    Tcl_Interp *interp; /* The current Tcl interpreter */
{

    int status = ThreadInit(interp);

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

    return Tcl_PkgProvideEx(interp, "Thread", PACKAGE_VERSION, NULL);

 * Side effects:
 *  The list of threads is initialized to include the current thread.
 *
 *----------------------------------------------------------------------
 */

static void
Init(interp)
    Tcl_Interp *interp;         /* Current interpreter. */
{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

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

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    int argc, rsrv = 0;
    const char *arg, *script;
    int flags = TCL_THREAD_NOFLAGS;

    Init(interp);

    /*

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReserveObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int 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;

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    int wait = 0;
    Tcl_ThreadId thrId = NULL;

    Init(interp);

    if (objc > 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "?-wait? ?threadId?");

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    Init(interp);

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

 * Side effects:
 *  Lots.  improper clean up of resources.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExitObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int 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;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    char thrHandle[THREAD_HNDLMAXLEN];

    Init(interp);

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

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    int ii, length;
    char *result, thrHandle[THREAD_HNDLMAXLEN];
    Tcl_ThreadId *thrIdArray;
    Tcl_DString threadNames;

    Init(interp);

static void
threadSendFree(void *ptr)
{
    Tcl_Free(ptr);
}

static void
threadSendObjFree(ClientData ptr)
{
    Tcl_DecrRefCount((Tcl_Obj *)ptr);
}

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

    size_t size;
    int cmd = 0, ret, ii = 0, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg;
    Tcl_Obj *var = NULL;

    ThreadClbkData *clbkPtr = NULL;

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

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

 * Side effects:
 *  Script is sent to all known threads except the caller thread.
 *
 *----------------------------------------------------------------------
 */

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

    int ii, nthreads;
    size_t size;
    const char *script;
    Tcl_ThreadId *thrIdArray;
    ThreadSendData *sendPtr, job;

    Init(interp);

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

    Tcl_Free(thrIdArray);
    Tcl_ResetResult(interp);

 * Side effects:
 *  Enters the event loop.
 *
 *----------------------------------------------------------------------
 */

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

    Init(interp);

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

 * Side effects:
 *  Registers an errorproc.
 *
 *----------------------------------------------------------------------
 */

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

    size_t len;
    char *proc;

    Init(interp);

    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?proc?");

        proc = Tcl_GetString(objv[1]);
        len = objv[1]->length;
        if (len == 0) {
            errorThreadId = NULL;
            errorProcString = NULL;
        } else {
            errorThreadId = Tcl_GetCurrentThread();
            errorProcString = 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(clientData)
    void *clientData;
{

    Tcl_MutexLock(&threadMutex);
    if (errorThreadId != Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        return;
    }
    Tcl_Free(errorProcString);
    errorThreadId = NULL;

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    Tcl_ThreadId thrId;

    Init(interp);

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

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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


    Tcl_ThreadId thrId;
    Tcl_Channel chan;

    Init(interp);

    /*

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    Tcl_Channel chan;

    Init(interp);

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

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    char *chanName;

    Init(interp);

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

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    Tcl_ThreadId thrId;

    Init(interp);

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

 *  A standard Tcl result.
 *
 * Side effects:
 *  None.
 *----------------------------------------------------------------------
 */
static int
ThreadConfigureObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    char *option, *value;
    Tcl_ThreadId thrId;         /* Id of the thread to configure */
    int i;                      /* Iterate over arg-value pairs. */
    Tcl_DString ds;             /* DString to hold result of
                                 * calling GetThreadOption. */

    if (objc < 2 || (objc % 2 == 1 && objc != 3)) {

 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCancelObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int 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;

 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSendEval(interp, clientData)
    Tcl_Interp *interp;
    void *clientData;
{

    ThreadSendData *sendPtr = clientData;
    char *script = (char*)sendPtr->clientData;

    return Tcl_EvalEx(interp, script, TCL_AUTO_LENGTH, TCL_EVAL_GLOBAL);
}

/*
 *----------------------------------------------------------------------

 * Side effects:
 *  New Tcl variable may be created
 *
 *----------------------------------------------------------------------
 */

static int
ThreadClbkSetVar(interp, clientData)
    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;

    /*

    return TCL_OK;

cleanup:
    Tcl_DecrRefCount(valObj);
    return rc;
}

static int ThreadClbkCommand(Tcl_Interp *interp, ClientData 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) {

 * Side effects:
 *  Create a thread.
 *
 *----------------------------------------------------------------------
 */

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

    char thrHandle[THREAD_HNDLMAXLEN];
    ThreadCtrl ctrl;
    Tcl_ThreadId thrId;

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

 * Side effects:
 *    A Tcl script is executed in a new thread.
 *
 *----------------------------------------------------------------------
 */

Tcl_ThreadCreateType
NewThread(clientData)
    void *clientData;
{

    ThreadCtrl *ctrlPtr = clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_Interp *interp;
    int result = TCL_OK;
    size_t scriptLen;
    char *evalScript;

    /*

    /*
     * 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(Tcl_Alloc(scriptLen+1), ctrlPtr->script);
    Tcl_CreateThreadExitHandler(ThreadExitProc, evalScript);

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

    ctrlPtr->script = NULL;

 * Side effects:
 *  Send an event.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadErrorProc(interp)
    Tcl_Interp *interp;         /* Interp that failed */
{

    ThreadSendData *sendPtr;
    const char *argv[3];
    char buf[THREAD_HNDLMAXLEN];
    const char *errorInfo;

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

#endif
    } else {
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        argv[0] = errorProcString;
        argv[1] = buf;
        argv[2] = errorInfo;

        sendPtr = 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);
    }

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
ListUpdate(tsdPtr)
    ThreadSpecificData *tsdPtr;
{

    if (tsdPtr == NULL) {
        tsdPtr = TCL_TSD_INIT(&dataKey);
    }

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

 * Side effects:
 *  Add the thread local storage to its list.
 *
 *----------------------------------------------------------------------
 */

static void
ListUpdateInner(tsdPtr)
    ThreadSpecificData *tsdPtr;
{

    if (threadList) {
        threadList->prevPtr = tsdPtr;
    }

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

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

static void
ListRemove(tsdPtr)
    ThreadSpecificData *tsdPtr;
{

    if (tsdPtr == NULL) {
        tsdPtr = TCL_TSD_INIT(&dataKey);
    }

    Tcl_MutexLock(&threadMutex);
    ListRemoveInner(tsdPtr);
    Tcl_MutexUnlock(&threadMutex);

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

static void
ListRemoveInner(tsdPtr)
    ThreadSpecificData *tsdPtr;
{

    if (tsdPtr->prevPtr || tsdPtr->nextPtr) {
        if (tsdPtr->prevPtr) {
            tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
        } else {
            threadList = tsdPtr->nextPtr;
        }
        if (tsdPtr->nextPtr) {

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    int ii, count = 0;
    ThreadSpecificData *tsdPtr;

    Tcl_MutexLock(&threadMutex);

    /*
     * First walk; find out how many threads are registered.

        return 0;
    }

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

    *thrIdArray = 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;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadExists(thrId)
     Tcl_ThreadId thrId;
{

    ThreadSpecificData *tsdPtr;

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

    return tsdPtr != NULL;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    ThreadSpecificData *tsdPtr;

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

 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCancel(interp, thrId, result, flags)
    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);

 *  The status of the exiting thread is left in the interp result
 *  area, but only in the case of success.
 *
 *----------------------------------------------------------------------
 */

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

    int ret, state;

    ret = Tcl_JoinThread(thrId, &state);

    if (ret == TCL_OK) {
        Tcl_SetIntObj(Tcl_GetObjResult (interp), state);
    } else {

 *  involved (specified and current) are modified. The channel is
 *  moved, all event handling for the channel is killed.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadTransfer(interp, thrId, chan)
    Tcl_Interp *interp;         /* The current interpreter. */
    Tcl_ThreadId thrId;         /* Thread Id of other interpreter. */
    Tcl_Channel  chan;          /* The channel to transfer */
{

    /* Steps to perform for the transfer:
     *
     * i.   Sanity checks: chan has to registered in interp, must not be
     *      shared. This automatically excludes the special channels for
     *      stdin, stdout and stderr!
     * ii.  Clear event handling.
     * iii. Bump reference counter up to prevent destruction during the

    ThreadCutChannel(interp, chan);

    /*
     * Wrap it into an event.
     */

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

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

    /*
     * Initialize the result fields.

 *  The thread-global lists of all known channels (transferList)
 *  is modified. All event handling for the channel is killed.
 *
 *----------------------------------------------------------------------
 */

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

    TransferEvent *evPtr;
    TransferResult *resultPtr;

    if (!Tcl_IsChannelRegistered(interp, chan)) {
    	Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_AUTO_LENGTH));
    }
    if (Tcl_IsChannelShared(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 = Tcl_Alloc(sizeof(TransferResult));
    evPtr     = Tcl_Alloc(sizeof(TransferEvent));

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

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

 *  The thread-global lists of all known channels (transferList)
 *  is modified.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadAttach(interp, chanName)
    Tcl_Interp *interp;         /* The current interpreter. */
    char *chanName;             /* The name of the channel to detach */
{

    int found = 0;
    Tcl_Channel chan = NULL;
    TransferResult *resPtr;

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

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    ThreadSpecificData *tsdPtr = NULL; /* ... of the target thread */

    int code;
    ThreadEvent *eventPtr;
    ThreadEventResult *resultPtr;

    /*

        }
    }

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

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

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

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

 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReserve(interp, thrId, operation, wait)
    Tcl_Interp *interp;                 /* Current interpreter */
    Tcl_ThreadId thrId;                 /* Target thread ID */
    int operation;                      /* THREAD_RESERVE | THREAD_RELEASE */
    int wait;                           /* Wait for thread to exit */
{

    int users, dowait = 0;
    ThreadEvent *evPtr;
    ThreadSpecificData *tsdPtr;

    Tcl_MutexLock(&threadMutex);

    /*

                resultPtr->errorCode   = NULL;
                resultPtr->errorInfo   = NULL;
                resultPtr->dstThreadId = thrId;
                resultPtr->srcThreadId = Tcl_GetCurrentThread();
                SpliceIn(resultPtr, resultList);
            }

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

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

 *
 * Side effects:
 *  Fills out the ThreadEventResult struct.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadEventProc(evPtr, mask)
    Tcl_Event *evPtr;           /* Really ThreadEvent */
    int mask;
{

    ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);

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

 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static void
ThreadSetResult(interp, code, resultPtr)
    Tcl_Interp *interp;
    int code;
    ThreadEventResult *resultPtr;
{

    const char *errorCode, *errorInfo;
    size_t size;

    if (interp == NULL) {
        code      = TCL_ERROR;
        errorInfo = "";
        errorCode = "THREAD";

    }
    Tcl_IncrRefCount(resultPtr->result);

    resultPtr->code = code;

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

static int
ThreadGetOption(interp, thrId, option, dsPtr)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
    char *option;
    Tcl_DString *dsPtr;
{

    size_t len;
    ThreadSpecificData *tsdPtr = NULL;

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

 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

static int
ThreadSetOption(interp, thrId, option, value)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
    char *option;
    char *value;
{

    size_t len = strlen(option);
    ThreadSpecificData *tsdPtr = NULL;

    Tcl_MutexLock(&threadMutex);

    tsdPtr = ThreadExistsInner(thrId);

 *
 * Side effects.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadIdleProc(clientData)
    void *clientData;
{

    int ret;
    ThreadSendData *sendPtr = clientData;

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

    Tcl_Release(sendPtr->interp);

 * Side effects:
 *  Fills out the TransferResult struct.
 *
 *----------------------------------------------------------------------
 */

static int
TransferEventProc(evPtr, mask)
    Tcl_Event *evPtr;           /* Really ThreadEvent */
    int mask;
{

    ThreadSpecificData    *tsdPtr = TCL_TSD_INIT(&dataKey);
    TransferEvent       *eventPtr = (TransferEvent *)evPtr;
    TransferResult     *resultPtr = eventPtr->resultPtr;
    Tcl_Interp            *interp = tsdPtr->interp;
    int code;
    const char* msg = NULL;

        }
    }
    if (resultPtr) {
        Tcl_MutexLock(&threadMutex);
        resultPtr->resultCode = code;
        if (msg != NULL) {
            size_t size = strlen(msg)+1;
            resultPtr->resultMsg = memcpy(Tcl_Alloc(size), msg, size);
        }
        Tcl_ConditionNotify(&resultPtr->done);
        Tcl_MutexUnlock(&threadMutex);
    }

    return 1;
}

 *
 * Side effects:
 *  Clears up mem specified in clientData
 *
 *----------------------------------------------------------------------
 */
static void
ThreadFreeProc(clientData)
    void *clientData;
{

    /*
     * This will free send and/or callback structures
     * since both are the same in the beginning.
     */

    ThreadSendData *anyPtr = clientData;

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

 *
 * Side effects:
 *  It cleans up our events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadDeleteEvent(eventPtr, clientData)
    Tcl_Event *eventPtr;        /* Really ThreadEvent */
    void *clientData;      /* dummy */
{

    if (eventPtr->proc == ThreadEventProc) {
        /*
         * Regular script event. Just dispose memory
         */
        ThreadEvent *evPtr = (ThreadEvent*)eventPtr;
        if (evPtr->sendData) {
            ThreadFreeProc(evPtr->sendData);

 * Side effects:
 *  It unblocks anyone that is waiting on a send to this thread.
 *  It cleans up any events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static void
ThreadExitProc(clientData)
    void *clientData;
{

    char *threadEvalScript = clientData;
    const char *diemsg = "target thread died";
    ThreadEventResult *resultPtr, *nextPtr;
    Tcl_ThreadId self = Tcl_GetCurrentThread();
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    TransferResult *tResultPtr, *tNextPtr;

        } else if (tResultPtr->dstThreadId == self) {
            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.
             */

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

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadGetHandle(thrId, handlePtr)
    Tcl_ThreadId thrId;
    char *handlePtr;
{

    sprintf(handlePtr, THREAD_HNDLPREFIX"%p", thrId);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadGetId --
 *
 *  Returns the ID of thread given it's Tcl handle.
 *
 * Results:
 *  Thread ID.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadGetId(interp, handleObj, thrIdPtr)
     Tcl_Interp *interp;
     Tcl_Obj *handleObj;
     Tcl_ThreadId *thrIdPtr;
{

    const char *thrHandle = Tcl_GetString(handleObj);

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

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

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
ErrorNoSuchThread(interp, thrId)
    Tcl_Interp *interp;
    Tcl_ThreadId thrId;
{

    char thrHandle[THREAD_HNDLMAXLEN];

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

 *  Events still pending in the thread event queue and ready to fire
 *  are not processed.
 *
 *----------------------------------------------------------------------
 */

static void
ThreadCutChannel(interp, chan)
    Tcl_Interp *interp;
    Tcl_Channel chan;
{

    Tcl_DriverWatchProc *watchProc;

    Tcl_ClearChannelHandlers(chan);

    watchProc   = Tcl_ChannelWatchProc(Tcl_GetChannelType(chan));

    /*

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    int ii, minw, maxw, idle;
    char buf[64], *exs = NULL, *cmd = NULL;
    ThreadPool *tpoolPtr;

    /*
     * Syntax:  tpool::create ?-minworkers count?
     *                        ?-maxworkers count?

            }
        } else if (OPT_CMP(opt, "-idletime")) {
            if (Tcl_GetIntFromObj(interp, objv[ii+1], &idle) != TCL_OK) {
                return TCL_ERROR;
            }
        } else if (OPT_CMP(opt, "-initcmd")) {
            const char *val = Tcl_GetString(objv[ii+1]);
            cmd  = strcpy(Tcl_Alloc(objv[ii+1]->length+1), val);
        } else if (OPT_CMP(opt, "-exitcmd")) {
            const char *val = Tcl_GetString(objv[ii+1]);
            exs  = strcpy(Tcl_Alloc(objv[ii+1]->length+1), val);
        } else {
            goto usage;
        }
    }

    /*
     * Do some consistency checking

        maxw = minw;
    }

    /*
     * Allocate and initialize thread pool structure
     */

    tpoolPtr = Tcl_Alloc(sizeof(ThreadPool));
    memset(tpoolPtr, 0, sizeof(ThreadPool));

    tpoolPtr->minWorkers  = minw;
    tpoolPtr->maxWorkers  = maxw;
    tpoolPtr->idleTime    = idle;
    tpoolPtr->initScript  = cmd;
    tpoolPtr->exitScript  = exs;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    Tcl_WideInt jobId = 0;
    int ii, detached = 0, nowait = 0;
    size_t len;
    const char *tpoolName, *script;
    TpoolResult *rPtr;
    ThreadPool *tpoolPtr;

        }
    }

    /*
     * Create new job ticket and put it on the list.
     */

    rPtr = Tcl_Alloc(sizeof(TpoolResult));
    memset(rPtr, 0, sizeof(TpoolResult));

    if (detached == 0) {
        jobId = ++tpoolPtr->jobId;
        rPtr->jobId = jobId;
    }

    rPtr->script    = strcpy(Tcl_Alloc(len+1), script);
    rPtr->scriptLen = len;
    rPtr->detached  = detached;
    rPtr->threadId  = Tcl_GetCurrentThread();

    PushWork(rPtr, tpoolPtr);
    Tcl_ConditionNotify(&tpoolPtr->cond);
    Tcl_MutexUnlock(&tpoolPtr->mutex);

 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolWaitObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    int ii, done;
    int wObjc;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *listVar = NULL;
    Tcl_Obj *waitList, *doneList, **wObjv;
    ThreadPool *tpoolPtr;

 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolCancelObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    int ii;
    int wObjc;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *listVar = NULL;
    Tcl_Obj *doneList, *waitList, **wObjv;
    ThreadPool *tpoolPtr;

 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolGetObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    int ret;
    Tcl_WideInt jobId;
    char *tpoolName;
    Tcl_Obj *resVar = NULL;
    ThreadPool *tpoolPtr;
    TpoolResult *rPtr;
    Tcl_HashEntry *hPtr;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    int ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::preserve tpoolId
     */

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    size_t ret;
    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::release tpoolId
     */

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::suspend tpoolId
     */

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    char *tpoolName;
    ThreadPool *tpoolPtr;

    /*
     * Syntax: tpool::resume tpoolId
     */

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    ThreadPool *tpoolPtr;
    Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);

    Tcl_MutexLock(&listMutex);
    for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) {
        char buf[32];
        sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);

 *
 * Side effects:
 *  Informs waiter thread (if any) about the new worker thread.
 *
 *----------------------------------------------------------------------
 */
static int
CreateWorker(interp, tpoolPtr)
    Tcl_Interp *interp;
    ThreadPool *tpoolPtr;
{

    Tcl_ThreadId id;
    TpoolResult result;

    /*
     * Initialize the result structure to be
     * passed to the new thread. This is used
     * as communication to and from the thread.

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_ThreadCreateType
TpoolWorker(clientData)
    void *clientData;
{

    TpoolResult          *rPtr = clientData;
    ThreadPool       *tpoolPtr = rPtr->tpoolPtr;

    int tout = 0;
    Tcl_Interp *interp;
    Tcl_Time waitTime, *idlePtr;
    const char *errMsg;

    } else {
        rPtr->retcode = 0;
    }
#endif

    if (rPtr->retcode == 1) {
        errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
        rPtr->result = strcpy(Tcl_Alloc(strlen(errMsg)+1), errMsg);
        Tcl_ConditionNotify(&tpoolPtr->cond);
        Tcl_MutexUnlock(&startMutex);
        goto out;
    }

    /*
     * Initialize the interpreter
     */

    if (tpoolPtr->initScript) {
        TpoolEval(interp, tpoolPtr->initScript, TCL_AUTO_LENGTH, rPtr);
        if (rPtr->retcode != TCL_OK) {
            rPtr->retcode = 1;
            errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
            rPtr->result  = strcpy(Tcl_Alloc(strlen(errMsg)+1), errMsg);
            Tcl_ConditionNotify(&tpoolPtr->cond);
            Tcl_MutexUnlock(&startMutex);
            goto out;
        }
    }

    /*

            break; /* Kill worker because pool is going down */
        }
        Tcl_MutexUnlock(&tpoolPtr->mutex);
        TpoolEval(interp, rPtr->script, rPtr->scriptLen, rPtr);
        Tcl_Free(rPtr->script);
        Tcl_MutexLock(&tpoolPtr->mutex);
        if (!rPtr->detached) {
            int new;
            Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone,
                                                 (void *)(size_t)rPtr->jobId, &new),
                             rPtr);
            SignalWaiter(tpoolPtr);
        } else {
            Tcl_Free(rPtr);
        }
    }

 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
RunStopEvent(eventPtr, mask)
    Tcl_Event *eventPtr;
    int mask;
{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    tsdPtr->stop = 1;
    return 1;
}

/*

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
PushWork(rPtr, tpoolPtr)
    TpoolResult *rPtr;
    ThreadPool *tpoolPtr;
{

    SpliceIn(rPtr, tpoolPtr->workHead);
    if (tpoolPtr->workTail == NULL) {
        tpoolPtr->workTail = rPtr;
    }
}

/*

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static TpoolResult *
PopWork(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    TpoolResult *rPtr = tpoolPtr->workTail;

    if (rPtr == NULL) {
        return NULL;
    }

    tpoolPtr->workTail = rPtr->prevPtr;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static void
PushWaiter(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    SpliceIn(tsdPtr->waitPtr, tpoolPtr->waitHead);
    if (tpoolPtr->waitTail == NULL) {
        tpoolPtr->waitTail = tsdPtr->waitPtr;
    }
}

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static TpoolWaiter*
PopWaiter(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    TpoolWaiter *waitPtr =  tpoolPtr->waitTail;

    if (waitPtr == NULL) {
        return NULL;
    }

    tpoolPtr->waitTail = waitPtr->prevPtr;

 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static ThreadPool*
GetTpool(tpoolName)
    const char *tpoolName;
{

    ThreadPool *tpoolPtr;

    Tcl_MutexLock(&listMutex);
    tpoolPtr = GetTpoolUnl(tpoolName);
    Tcl_MutexUnlock(&listMutex);

    return tpoolPtr;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */

static ThreadPool*
GetTpoolUnl (tpoolName)
    const char *tpoolName;
{

    ThreadPool *tpool;
    ThreadPool *tpoolPtr = NULL;

    if (sscanf(tpoolName, TPOOL_HNDLPREFIX"%p", &tpool) != 1) {
        return NULL;
    }
    for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) {

 *
 * Side effects:
 *  Many, depending on the script.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolEval(interp, script, scriptLen, rPtr)
    Tcl_Interp *interp;
    char *script;
    size_t scriptLen;
    TpoolResult *rPtr;
{

    int ret;
    size_t reslen;
    const char *result;
    const char *errorCode, *errorInfo;

    ret = Tcl_EvalEx(interp, script, scriptLen, TCL_EVAL_GLOBAL);
    if (rPtr == NULL || rPtr->detached) {
        return ret;
    }
    rPtr->retcode = ret;
    if (ret == TCL_ERROR) {
        errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
        errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        if (errorCode != NULL) {
            rPtr->errorCode = Tcl_Alloc(1 + strlen(errorCode));
            strcpy(rPtr->errorCode, errorCode);
        }
        if (errorInfo != NULL) {
            rPtr->errorInfo = Tcl_Alloc(1 + strlen(errorInfo));
            strcpy(rPtr->errorInfo, errorInfo);
        }
    }

    result = Tcl_GetString(Tcl_GetObjResult(interp));
    reslen = Tcl_GetObjResult(interp)->length;

    if (reslen == 0) {
        rPtr->result = threadEmptyResult;
    } else {
        rPtr->result = strcpy(Tcl_Alloc(1 + reslen), result);
    }

    return ret;
}

/*
 *----------------------------------------------------------------------

 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
SetResult(interp, rPtr)
    Tcl_Interp *interp;
    TpoolResult *rPtr;
{

    if (rPtr->retcode == TCL_ERROR) {
        if (rPtr->errorCode) {
            if (interp) {
                Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_AUTO_LENGTH));
            }
            Tcl_Free(rPtr->errorCode);
            rPtr->errorCode = NULL;

 *
 * Side effects:
 *  May tear-down the threadpool if refcount drops to 0 or below.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolReserve(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    return ++tpoolPtr->refCount;
}

/*
 *----------------------------------------------------------------------
 *
 * TpoolRelease --
 *
 *  Does the pool preserve and/or release. Assumes caller holds
 *  the listMutex.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  May tear-down the threadpool if refcount drops to 0 or below.
 *
 *----------------------------------------------------------------------
 */
static size_t
TpoolRelease(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    TpoolResult *rPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    if (tpoolPtr->refCount-- > 1) {
        return tpoolPtr->refCount;

 * Side effects:
 *  During the suspended state, pool worker threads wlll not timeout
 *  even if the worker inactivity timer has been configured.
 *
 *----------------------------------------------------------------------
 */
static void
TpoolSuspend(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    Tcl_MutexLock(&tpoolPtr->mutex);
    tpoolPtr->suspend = 1;
    Tcl_MutexUnlock(&tpoolPtr->mutex);
}

/*
 *----------------------------------------------------------------------

 *
 * Side effects:
 *  Pool workers may be started or awaken.
 *
 *----------------------------------------------------------------------
 */
static void
TpoolResume(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    Tcl_MutexLock(&tpoolPtr->mutex);
    tpoolPtr->suspend = 0;
    Tcl_ConditionNotify(&tpoolPtr->cond);
    Tcl_MutexUnlock(&tpoolPtr->mutex);
}

/*

 *
 * Side effects:
 *  The waiter thread will exit from the event loop.
 *
 *----------------------------------------------------------------------
 */
static void
SignalWaiter(tpoolPtr)
    ThreadPool *tpoolPtr;
{

    TpoolWaiter *waitPtr;
    Tcl_Event *evPtr;

    waitPtr = PopWaiter(tpoolPtr);
    if (waitPtr == NULL) {
        return;
    }

    evPtr = Tcl_Alloc(sizeof(Tcl_Event));
    evPtr->proc = RunStopEvent;

    Tcl_ThreadQueueEvent(waitPtr->threadId,(Tcl_Event*)evPtr,TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(waitPtr->threadId);
}

/*

 */
static void
InitWaiter ()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (tsdPtr->waitPtr == NULL) {
        tsdPtr->waitPtr = Tcl_Alloc(sizeof(TpoolWaiter));
        tsdPtr->waitPtr->prevPtr  = NULL;
        tsdPtr->waitPtr->nextPtr  = NULL;
        tsdPtr->waitPtr->threadId = Tcl_GetCurrentThread();
        Tcl_CreateThreadExitHandler(ThrExitHandler, tsdPtr);
    }
}


 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
ThrExitHandler(clientData)
    void *clientData;
{

    ThreadSpecificData *tsdPtr = clientData;

    Tcl_Free(tsdPtr->waitPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AppExitHandler
 *
 *  Deletes all threadpools on application exit.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
AppExitHandler(clientData)
    void *clientData;
{

    ThreadPool *tpoolPtr;

    Tcl_MutexLock(&listMutex);
    /*
     * Restart with head of list each time until empty. [Bug 1427570]
     */
    for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolList) {

 *  On first load, creates application exit handler to clean up
 *  any threadpools left.
 *
 *----------------------------------------------------------------------
 */

int
Tpool_Init (interp)
    Tcl_Interp *interp;                 /* Interp where to create cmds */
{

    static int initialized;

    TCL_CMD(interp, TPOOL_CMD_PREFIX"create",   TpoolCreateObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"names",    TpoolNamesObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"post",     TpoolPostObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"wait",     TpoolWaitObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"cancel",   TpoolCancelObjCmd);

 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    char type;
    SpMutex *mutexPtr;

    static const char *const cmdOpts[] = {

            }
        }

        /*
         * Create the requested mutex
         */

        mutexPtr = Tcl_Alloc(sizeof(SpMutex));
        mutexPtr->type   = type;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        /*
         * Generate Tcl name for this mutex

 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    int opt, ret;
    size_t nameLen;
    const char *mutexName;
    SpMutex *mutexPtr;
    Sp_ReadWriteMutex *rwPtr;
    Sp_AnyMutex **lockPtr;

    if (opt == (int)w_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        mutexPtr = Tcl_Alloc(sizeof(SpMutex));
        mutexPtr->type   = WMUTEXID;
        mutexPtr->refcnt = 0;
        mutexPtr->bucket = NULL;
        mutexPtr->hentry = NULL;
        mutexPtr->lock   = NULL; /* Will be auto-initialized */

        nameObj = GetName(mutexPtr->type, (void*)mutexPtr);

 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    int opt, ret, timeMsec = 0;
    size_t nameLen;
    const char *condvName, *mutexName;
    SpMutex *mutexPtr;
    SpCondv *condvPtr;

    static const char *const cmdOpts[] = {

    if (opt == (int)c_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        condvPtr = Tcl_Alloc(sizeof(SpCondv));
        condvPtr->refcnt = 0;
        condvPtr->bucket = NULL;
        condvPtr->hentry = NULL;
        condvPtr->mutex  = NULL;
        condvPtr->cond   = NULL; /* Will be auto-initialized */

        nameObj = GetName(CONDVID, (void*)condvPtr);

 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    int ret, optx, internal;
    const char *mutexName;
    Tcl_Obj *scriptObj;
    SpMutex *mutexPtr = NULL;
    static Sp_RecursiveMutex evalMutex;

    /*

 *
 *----------------------------------------------------------------------
 */

static void
AddAnyItem(int type, const char *handle, size_t len, SpItem *itemPtr)
{
    int new;
    SpBucket *bucketPtr = GetBucket(type, handle, len);
    Tcl_HashEntry *hashEntryPtr;

    Tcl_MutexLock(&bucketPtr->lock);

    hashEntryPtr = Tcl_CreateHashEntry(&bucketPtr->handles, handle, &new);
    Tcl_SetHashValue(hashEntryPtr, itemPtr);

    itemPtr->refcnt = 0;
    itemPtr->bucket = bucketPtr;
    itemPtr->hentry = hashEntryPtr;

    Tcl_MutexUnlock(&bucketPtr->lock);

 *      Initializes shared hash table for storing sync primitive
 *      handles and pointers.
 *
 *----------------------------------------------------------------------
 */

int
Sp_Init (interp)
    Tcl_Interp *interp;                 /* Interp where to create cmds */
{

    SpBucket *bucketPtr;

    if (!initOnce) {
        Tcl_MutexLock(&initMutex);
        if (!initOnce) {
            int ii;
            for (ii = 0; ii < NUMSPBUCKETS; ii++) {

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == NULL) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == NULL) {
            *muxPtr = Tcl_Alloc(sizeof(Sp_ExclusiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    /*
     * Try locking if not currently locked by anybody.

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_RecursiveMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_RecursiveMutex_*)0) {
            *muxPtr =
                Tcl_Alloc(sizeof(Sp_RecursiveMutex_));
            memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr =
                Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;

    /*
     * Allocate the mutex structure on first access
     */

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr =
                Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;

/*
 * This is the header file for the module that implements some missing
 * synchronization priomitives from the Tcl API.
 *
 * Copyright (c) 2002 by Zoran Vasiljevic.
 *
 * See the file "license.txt" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ---------------------------------------------------------------------------
 */

                   const char *cmdName,                /* Name of command to register */
                   Tcl_ObjCmdProc *objProc,            /* Object-based command procedure */
                   Tcl_CmdDeleteProc *delProc,         /* Command delete procedure */
                   int aolSpecial)
{
    size_t len = strlen(cmdName) + strlen(TSV_CMD_PREFIX) + 1;
    size_t len2 = strlen(cmdName) + strlen(TSV_CMD2_PREFIX) + 1;
    SvCmdInfo *newCmd = Tcl_Alloc(sizeof(SvCmdInfo) + len + len2);

    /*
     * Setup new command structure
     */

    newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo));
    newCmd->cmdName2 = newCmd->cmdName + len;

 */

void
Sv_RegisterObjType(
                   const Tcl_ObjType *typePtr,               /* Type of object to register */
                   Tcl_DupInternalRepProc *dupProc)    /* Custom object duplicator */
{
    RegType *newType = Tcl_Alloc(sizeof(RegType));

    /*
     * Setup new type structure
     */

    newType->typePtr = typePtr;
    newType->dupIntRepProc = dupProc;

 *-----------------------------------------------------------------------------
 */

void
Sv_RegisterPsStore(const PsStore *psStorePtr)
{

    PsStore *psPtr = Tcl_Alloc(sizeof(PsStore));

    *psPtr = *psStorePtr;

    /*
     * Plug-in in shared list
     */

     */

    Tcl_MutexLock(&svMutex);
    for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) {
        if (strcmp(tmpPtr->type, type) == 0) {
            tmpPtr->psHandle = tmpPtr->psOpen(addr);
            if (tmpPtr->psHandle) {
                psPtr = Tcl_Alloc(sizeof(PsStore));
                *psPtr = *tmpPtr;
                psPtr->nextPtr = NULL;
            }
            break;
        }
    }
    Tcl_MutexUnlock(&svMutex);

static Container *
AcquireContainer(
                 Array *arrayPtr,
                 const char *key,
                 int flags)
{
    int new;
    Tcl_Obj *tclObj = NULL;
    Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key);

    if (hPtr == NULL) {
        PsStore *psPtr = arrayPtr->psPtr;
        if (psPtr) {
            char *val = NULL;
            size_t len = 0;
            if (psPtr->psGet(psPtr->psHandle, key, &val, &len) == 0) {
                tclObj = Tcl_NewStringObj(val, len);
                psPtr->psFree(psPtr->psHandle, val);
            }
        }
        if (!(flags & FLAGS_CREATEVAR) && tclObj == NULL) {
            return NULL;
        }
        if (tclObj == NULL) {
            tclObj = Tcl_NewObj();
        }
        hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &new);
        Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
    }

    return (Container*)Tcl_GetHashValue(hPtr);
}

/*

    char *key, *val;

    switch (mode) {
    case SV_UNCHANGED: return TCL_OK;
    case SV_ERROR:     return TCL_ERROR;
    case SV_CHANGED:
        if (psPtr) {
            key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
            val = Tcl_GetString(svObj->tclObj);
            len = svObj->tclObj->length;
            if (psPtr->psPut(psPtr->psHandle, key, val, len) == -1) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
                return TCL_ERROR;
            }

    }
    if (svObj->handlePtr) {
        Tcl_DeleteHashEntry(svObj->handlePtr);
    }
    if (svObj->entryPtr) {
        PsStore *psPtr = svObj->arrayPtr->psPtr;
        if (psPtr) {
            char *key = Tcl_GetHashKey(&svObj->arrayPtr->vars,svObj->entryPtr);
            if (psPtr->psDelete(psPtr->psHandle, key) == -1) {
                return TCL_ERROR;
            }
        }
        Tcl_DeleteHashEntry(svObj->entryPtr);
    }

 */

static Array *
CreateArray(
            Bucket *bucketPtr,
            const char *arrayName)
{
    int new;
    Array *arrayPtr;
    Tcl_HashEntry *hPtr;

    hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &new);
    if (!new) {
        return (Array*)Tcl_GetHashValue(hPtr);
    }

    arrayPtr = Tcl_Alloc(sizeof(Array));
    arrayPtr->bucketPtr = bucketPtr;
    arrayPtr->entryPtr  = hPtr;
    arrayPtr->psPtr     = NULL;
    arrayPtr->bindAddr  = NULL;

    Tcl_InitHashTable(&arrayPtr->vars, TCL_STRING_KEYS);
    Tcl_SetHashValue(hPtr, arrayPtr);

    Container tmp[2];
    size_t objSizePlusPadding = (size_t)(((char*)(tmp+1))-(char*)tmp);
    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
    char *basePtr;
    register Container *prevPtr = NULL, *objPtr = NULL;
    register int i;

    basePtr = Tcl_Alloc(bytesToAlloc);
    memset(basePtr, 0, bytesToAlloc);

    objPtr = (Container*)basePtr;
    objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */

    for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
        objPtr->nextPtr = prevPtr;

 *  Some object may, when copied, loose their type, i.e. will become
 *  just plain string objects.
 *
 *-----------------------------------------------------------------------------
 */

Tcl_Obj *
Sv_DuplicateObj(objPtr)
    register Tcl_Obj *objPtr;        /* The object to duplicate. */
{

    register Tcl_Obj *dupPtr = Tcl_NewObj();

    /*
     * Handle the internal rep
     */

    if (objPtr->typePtr != NULL) {

     * Handle the string rep
     */

    if (objPtr->bytes == NULL) {
        dupPtr->bytes = NULL;
    } else if (objPtr->bytes != Sv_tclEmptyStringRep) {
        /* A copy of TclInitStringRep macro */
        dupPtr->bytes = Tcl_Alloc((unsigned)objPtr->length + 1);
        if (objPtr->length > 0) {
            memcpy((void*)dupPtr->bytes,(void*)objPtr->bytes,
                   (unsigned)objPtr->length);
        }
        dupPtr->length = objPtr->length;
        dupPtr->bytes[objPtr->length] = '\0';
    }

static int
SvObjObjCmd(
            void *arg,                     /* != NULL if aolSpecial */
            Tcl_Interp *interp,                 /* Current interpreter. */
            int objc,                   /* Number of arguments. */
            Tcl_Obj *const objv[])              /* Argument objects. */
{
    int new, off, ret, flg;
    char buf[128];
    Tcl_Obj *val = NULL;
    Container *svObj = NULL;

    /*
     * Syntax: sv::object array key ?var?
     */

        break;
    case TCL_ERROR:
        return TCL_ERROR;
    }

    if (svObj->handlePtr == NULL) {
        Tcl_HashTable *handles = &svObj->arrayPtr->bucketPtr->handles;
        svObj->handlePtr = Tcl_CreateHashEntry(handles, (char*)svObj, &new);
    }

    /*
     * Format the command name
     */

    sprintf(buf, "::%p", (int*)svObj);

    } else if (index == AGET || index == ANAMES) {
        if (arrayPtr) {
            Tcl_HashSearch search;
            Tcl_Obj *resObj = Tcl_NewListObj(0, NULL);
            const char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]);
            Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
            while (hPtr) {
                char *key = Tcl_GetHashKey(&arrayPtr->vars, hPtr);
                if (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0)) {
                    Tcl_ListObjAppendElement(interp, resObj,
                            Tcl_NewStringObj(key, TCL_AUTO_LENGTH));
                    if (index == AGET) {
                        elObj = (Container*)Tcl_GetHashValue(hPtr);
                        Tcl_ListObjAppendElement(interp, resObj,
                                Sv_DuplicateObj(elObj->tclObj));

         * storage and cache all key/value pairs found there into tne
         * newly created shared array.
         */

        PsStore *psPtr;
        Tcl_HashEntry *hPtr;
        size_t len;
        int new;
        char *psurl, *key = NULL, *val = NULL;

        if (objc < 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "array handle");
            ret = TCL_ERROR;
            goto cmdExit;
        }

            ret = TCL_ERROR;
            goto cmdExit;
        }
        if (arrayPtr) {
            Tcl_HashSearch search;
            hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
            arrayPtr->psPtr = psPtr;
            arrayPtr->bindAddr = strcpy(Tcl_Alloc(len+1), psurl);
            while (hPtr) {
                svObj = Tcl_GetHashValue(hPtr);
                if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) {
                    ret = TCL_ERROR;
                    goto cmdExit;
                }
                hPtr = Tcl_NextHashEntry(&search);
            }
        } else {
            arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
            arrayPtr->psPtr = psPtr;
            arrayPtr->bindAddr = strcpy(Tcl_Alloc(len+1), psurl);
        }
        if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) {
            do {
                Tcl_Obj * tclObj = Tcl_NewStringObj(val, len);
                hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &new);
                Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
                psPtr->psFree(psPtr->psHandle, val);
            } while (!psPtr->psNext(psPtr->psHandle, &key, &val, &len));
        }

    } else if (index == AUNBIND) {
        if (!arrayPtr || !arrayPtr->psPtr) {

    resObj = Tcl_NewListObj(0, NULL);

    for (i = 0; i < NUMBUCKETS; i++) {
        Bucket *bucketPtr = &buckets[i];
        LOCK_BUCKET(bucketPtr);
        hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
        while (hPtr) {
            char *key = Tcl_GetHashKey(&bucketPtr->arrays, hPtr);
            if ((arg==NULL || (*key != '.')) /* Hide .<name> arrays for AOL*/ &&
                (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0))) {
                Tcl_ListObjAppendElement(interp, resObj,
                        Tcl_NewStringObj(key, -1));
            }
            hPtr = Tcl_NextHashEntry(&search);
        }

static int
SvIncrObjCmd(
             void *arg,                     /* Pointer to object container */
             Tcl_Interp *interp,                 /* Current interpreter. */
             int objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int off, ret, flg, new = 0;
    Tcl_WideInt incrValue = 1, currValue = 0;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::incr array key ?increment?
     *          $object incr ?increment?
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        if (ret != TCL_BREAK) {
            return TCL_ERROR;
        }
        flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
        Tcl_ResetResult(interp);
        ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
        if (ret != TCL_OK) {
            return TCL_ERROR;
        }
        new = 1;
    }
    if ((objc - off)) {
        ret = Tcl_GetWideIntFromObj(interp, objv[off], &incrValue);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
    }
    if (new) {
        currValue = 0;
    } else {
        ret = Tcl_GetWideIntFromObj(interp, svObj->tclObj, &currValue);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
    }

static int
SvMoveObjCmd(
             void *arg,                     /* Pointer to object container. */
             Tcl_Interp *interp,                 /* Current interpreter. */
             int objc,                   /* Number of arguments. */
             Tcl_Obj *const objv[])              /* Argument objects. */
{
    int ret, off, new;
    const char *toKey;
    Tcl_HashEntry *hPtr;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::move array key to
     *          $object move to
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }

    toKey = Tcl_GetString(objv[off]);
    hPtr = Tcl_CreateHashEntry(&svObj->arrayPtr->vars, toKey, &new);

    if (!new) {
        Tcl_AppendResult(interp, "key \"", toKey, "\" exists", NULL);
        goto cmd_err;
    }
    if (svObj->entryPtr) {
        char *key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
        if (svObj->arrayPtr->psPtr) {
            PsStore *psPtr = svObj->arrayPtr->psPtr;
            if (psPtr->psDelete(psPtr->psHandle, key) == -1) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
                return TCL_ERROR;
            }

 * Side effects
 *    Many new command created in current interpreter. Global data
 *    structures used by them initialized as well.
 *
 *-----------------------------------------------------------------------------
 */
int
Sv_Init (interp)
    Tcl_Interp *interp;
{

    int i;
    Bucket *bucketPtr;
    SvCmdInfo *cmdPtr;
    Tcl_Obj *obj;

#ifdef SV_FINALIZE
    /*

    /*
     * Create array of buckets and initialize each bucket
     */

    if (buckets == NULL) {
        Tcl_MutexLock(&bucketsMutex);
        if (buckets == NULL) {
            buckets = Tcl_Alloc(sizeof(Bucket) * NUMBUCKETS);

            for (i = 0; i < NUMBUCKETS; ++i) {
                bucketPtr = &buckets[i];
                memset(bucketPtr, 0, sizeof(Bucket));
                Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS);
                Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS);
            }

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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

    int i, off, ret, flg;
    char *key;
    Tcl_Obj *val;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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

    int ret, flg, off;
    char *key;
    Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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

    int i, off, ret;
    char *key;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          sv::keyldel array lkey key ?key ...?

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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

    int ret, off;
    char *key = NULL;
    Tcl_Obj *listObj = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpopObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    int ret, off, llen, iarg = 0;
    size_t index = 0;
    Tcl_Obj *elPtr = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:

    }
    if (iarg) {
        ret = Tcl_GetIntForIndex(interp, objv[iarg], llen-1, &index);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
    }
    if (index < 0 || index >= llen) {
        goto cmd_ok; /* Ignore out-of bounds, like Tcl does */
    }
    ret = Tcl_ListObjIndex(interp, svObj->tclObj, index, &elPtr);
    if (ret != TCL_OK) {
        goto cmd_err;
    }

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpushObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    int off, ret, flg, llen;
    size_t index = 0;
    Tcl_Obj *args[1];
    Container *svObj = (Container*)arg;

    /*
     * Syntax:

        goto cmd_err;
    }
    if ((objc - off) == 2) {
        ret = Tcl_GetIntForIndex(interp, objv[off+1], llen, &index);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
        if (index < 0) {
            index = 0;
        } else if (index > llen) {
            index = llen;
        }
    }

    args[0] = Sv_DuplicateObj(objv[off]);
    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, 1, args);
    if (ret != TCL_OK) {

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLappendObjCmd(arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    int i, ret, flg, off;
    Tcl_Obj *dup;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lappend array key value ?value ...?

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLreplaceObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    const char *firstArg;
    size_t argLen;
    int ret, off, llen, ndel, nargs, i, j;
    size_t first, last;
    Tcl_Obj **args = NULL;
    Container *svObj = (Container*)arg;

    ret = Tcl_GetIntForIndex(interp, objv[off+1], llen-1, &last);
    if (ret != TCL_OK) {
        goto cmd_err;
    }

    firstArg = Tcl_GetString(objv[off]);
    argLen = objv[off]->length;
    if (first < 0)  {
        first = 0;
    }
    if (llen && first >= llen && strncmp(firstArg, "end", argLen)) {
        Tcl_AppendResult(interp, "list doesn't have element ", firstArg, NULL);
        goto cmd_err;
    }
    if (last >= llen) {
        last = llen - 1;
    }
    if (first <= last) {
        ndel = last - first + 1;
    } else {
        ndel = 0;
    }

    nargs = objc - (off + 2);
    if (nargs) {
        args = Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
        for(i = off + 2, j = 0; i < objc; i++, j++) {
            args[j] = Sv_DuplicateObj(objv[i]);
        }
    }

    ret = Tcl_ListObjReplace(interp, svObj->tclObj, first, ndel, nargs, args);
    if (args) {

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLrangeObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    int ret, off, llen, nargs, i, j;
    size_t first, last;
    Tcl_Obj **elPtrs, **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lrange array key first last
     *          $list lrange first last

    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = Tcl_GetIntForIndex(interp, objv[off+1], llen-1, &last);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (first < 0)  {
        first = 0;
    }
    if (last >= llen) {
        last = llen - 1;
    }
    if (first > last) {
        goto cmd_ok;
    }

    nargs = last - first + 1;
    args  = Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
    for (i = first, j = 0; i <= last; i++, j++) {
        args[j] = Sv_DuplicateObj(elPtrs[i]);
    }

    Tcl_ResetResult(interp);
    Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args);
    Tcl_Free(args);

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLinsertObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    int off, ret, flg, llen, nargs, i, j;
    size_t index = 0;
    Tcl_Obj **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:

    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = Tcl_GetIntForIndex(interp, objv[off], llen, &index);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (index < 0) {
        index = 0;
    } else if (index > llen) {
        index = llen;
    }

    nargs = objc - (off + 1);
    args  = Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
    for (i = off + 1, j = 0; i < objc; i++, j++) {
         args[j] = Sv_DuplicateObj(objv[i]);
    }
    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, nargs, args);
    if (ret != TCL_OK) {
        for (i = off + 1, j = 0; i < objc; i++, j++) {
            Tcl_DecrRefCount(args[j]);

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLlengthObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    int llen, off, ret;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::llength array key
     *          $list llength

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsearchObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    size_t length;
    int ret, off, listc, mode, imode, ipatt, index, match, i;
    const char *patBytes;
    Tcl_Obj **listv;
    Container *svObj = (Container*)arg;

    static const char *const modes[] = {"-exact", "-glob", "-regexp", NULL};

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLindexObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    Tcl_Obj **elPtrs;
    int ret, off, llen;
    size_t index;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:

    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = Tcl_GetIntForIndex(interp, objv[off], llen-1, &index);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (index >= 0 && index < llen) {
        Tcl_SetObjResult(interp, Sv_DuplicateObj(elPtrs[index]));
    }

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);

 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsetObjCmd (arg, interp, objc, objv)
    void *arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

    Tcl_Obj *lPtr;
    int ret, argc, off;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lset array key index ?index ...? value

 *      available to Tcl API programmer. We could include the tclInt.h and
 *      get the copy more efficient using list internals, but ...
 *
 *-----------------------------------------------------------------------------
 */

static void
DupListObjShared(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;           /* Object with internal rep to set. */
{

    int i;
    int llen;
    Tcl_Obj *elObj, **newObjList;

    Tcl_ListObjLength(NULL, srcPtr, &llen);
    if (llen == 0) {
        (*srcPtr->typePtr->dupIntRepProc)(srcPtr, copyPtr);
        copyPtr->refCount = 0;
        return;
    }

    newObjList = Tcl_Alloc(llen*sizeof(Tcl_Obj*));

    for (i = 0; i < llen; i++) {
        Tcl_ListObjIndex(NULL, srcPtr, i, &elObj);
        newObjList[i] = Sv_DuplicateObj(elObj);
    }

    Tcl_SetListObj(copyPtr, llen, newObjList);

 *  Actual return value of this procedure is irrelevant to the caller,
 *  and it should be either NULL or non-NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SvLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
     Tcl_Interp *interp;     /* Tcl interpreter */
     Tcl_Obj *listPtr;       /* Pointer to the list being modified */
     int indexCount;         /* Number of index args */
     Tcl_Obj **indexArray;
     Tcl_Obj *valuePtr;      /* Value arg to 'lset' */
{

    int elemCount, result, i;
    size_t index;
    Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;

    /*
     * Determine whether the index arg designates a list
     * or a single index.

            break;
        }

        /*
         * Check that the index is in range.
         */

        if (index < 0 || index >= elemCount) {
            Tcl_SetObjResult(interp,
                             Tcl_NewStringObj("list index out of range", -1));
            result = TCL_ERROR;
            break;
        }

        /*