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 ckalloc.  Also macro that does the
 * same with a string that might contain zero bytes,
 */

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

#define ckbinstrdup(sourceStr, length) \
  ((char *) memcpy (ckalloc (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(ClientData   clientData,






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

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

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

static int
Tcl_KeylkeysObjCmd(ClientData   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 = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));

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

 *   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++) {
        ckfree (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 = (keylEntry_t *)

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

    ckfree (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 = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));

 *
 * 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 = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));

 * 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, 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 =

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

 * 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)
    ClientData   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)
    ClientData   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)
    ClientData   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)
    ClientData   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;
    Tcl_RegisterObjType(&keyedListType);

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

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

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

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

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

static Tcl_ObjCmdProc ThreadAttachObjCmd;

#ifdef TCL_TIP285
static Tcl_ObjCmdProc ThreadCancelObjCmd;
#endif

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

    if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
        if ((sizeof(size_t) != sizeof(int))
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 7 && defined(TCL_NO_DEPRECATED)
                /* As long as Tcl 8.7 is not final, this allows the Thread extension */
                /* to be loadable on Tcl 9.0, provided it is compiled against Tcl 8.7+ headers */
                || !(Tcl_InitStubs)(interp, "8.4-",
                (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)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

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

    Init(interp);

    /*

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

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

    Tcl_ThreadId thrId = 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)
    ClientData  dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

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

    Init(interp);

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

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

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

    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)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

    char thrHandle[THREAD_HNDLMAXLEN];

    Init(interp);

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

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

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

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

    Init(interp);

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

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

    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;

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

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

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

    Init(interp);

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

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

    Init(interp);

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

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

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

    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 = ckalloc(1+strlen(proc));
            strcpy(errorProcString, proc);
            Tcl_DeleteThreadExitHandler(ThreadFreeError, NULL);
            Tcl_CreateThreadExitHandler(ThreadFreeError, NULL);
        }
    }
    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

static void
ThreadFreeError(clientData)
    ClientData clientData;
{

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

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

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

    Tcl_ThreadId thrId;

    Init(interp);

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

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

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


    Tcl_ThreadId thrId;
    Tcl_Channel chan;

    Init(interp);

    /*

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

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

    Tcl_Channel chan;

    Init(interp);

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

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

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

    char *chanName;

    Init(interp);

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

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

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

    Tcl_ThreadId thrId;

    Init(interp);

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

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

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

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

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

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

    Tcl_ThreadId thrId;
    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;
    ClientData clientData;
{

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

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

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

static int
ThreadClbkSetVar(interp, clientData)
    Tcl_Interp *interp;
    ClientData clientData;
{

    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    Tcl_Obj *var = (Tcl_Obj *)clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;
    int rc = TCL_OK;

    /*

 * 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)
    ClientData clientData;
{

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

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

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

 * 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

 *  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", -1));
    }
    if (Tcl_IsChannelShared(chan)) {

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

    /*

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

    /*

 *
 * 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(ckalloc(size), errorCode, size);
    } else {
        resultPtr->errorCode = NULL;
    }
    if (errorInfo != NULL) {
        size = strlen(errorInfo) + 1;
        resultPtr->errorInfo = memcpy(ckalloc(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)
    ClientData clientData;
{

    int ret;
    ThreadSendData *sendPtr = (ThreadSendData*)clientData;

    ret = (*sendPtr->execProc)(sendPtr->interp, (ClientData)sendPtr);
    if (ret != TCL_OK) {
        ThreadErrorProc(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(ckalloc(size), msg, size);
        }
        Tcl_ConditionNotify(&resultPtr->done);
        Tcl_MutexUnlock(&threadMutex);
    }

    return 1;
}

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

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

    ThreadSendData *anyPtr = (ThreadSendData*)clientData;

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

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

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

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

    TransferResult *tResultPtr, *tNextPtr;

        } 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(ckalloc(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)
    ClientData  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(ckalloc(objv[ii+1]->length+1), val);
        } else if (OPT_CMP(opt, "-exitcmd")) {
            const char *val = Tcl_GetString(objv[ii+1]);
            exs  = strcpy(ckalloc(objv[ii+1]->length+1), val);
        } else {
            goto usage;
        }
    }

    /*
     * Do some consistency checking

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

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

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

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

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

    rPtr->script    = strcpy(ckalloc(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)
    ClientData  dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int         objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{

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

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

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

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

    int ret;
    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)
    ClientData  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)
    ClientData  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)
    ClientData  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)
    ClientData  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)
    ClientData  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)
    ClientData clientData;
{

    TpoolResult          *rPtr = (TpoolResult*)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(ckalloc(strlen(errMsg)+1), errMsg);
        Tcl_ConditionNotify(&tpoolPtr->cond);
        Tcl_MutexUnlock(&startMutex);
        goto out;
    }

    /*
     * Initialize the interpreter
     */

    if (tpoolPtr->initScript) {
        TpoolEval(interp, tpoolPtr->initScript, -1, rPtr);
        if (rPtr->retcode != TCL_OK) {
            rPtr->retcode = 1;
            errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
            rPtr->result  = strcpy(ckalloc(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);
        ckfree(rPtr->script);
        Tcl_MutexLock(&tpoolPtr->mutex);
        if (!rPtr->detached) {
            int new;
            Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone,
                                                 (void *)(size_t)rPtr->jobId, &new),
                             (ClientData)rPtr);
            SignalWaiter(tpoolPtr);
        } else {
            ckfree((char*)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 = ckalloc(1 + strlen(errorCode));
            strcpy(rPtr->errorCode, errorCode);
        }
        if (errorInfo != NULL) {
            rPtr->errorInfo = ckalloc(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(ckalloc(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,-1));
            }
            ckfree(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;
    }

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

    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;

    ckfree((char*)tsdPtr->waitPtr);
}

/*
 *----------------------------------------------------------------------

 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
AppExitHandler(clientData)
    ClientData 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)
    ClientData 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 *cmdOpts[] = {

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

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

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

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

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

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

    static const char *cmdOpts[] = {

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

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

    int ret, 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, (ClientData)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++) {

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

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, -1));
                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 = (Array*)ckalloc(sizeof(Array));
    arrayPtr->bucketPtr = bucketPtr;
    arrayPtr->entryPtr  = hPtr;
    arrayPtr->psPtr     = NULL;

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

static int
SvObjObjCmd(
            ClientData 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);
    svObj->aolSpecial = (arg != NULL);
    Tcl_CreateObjCommand(interp, buf, (ClientData)SvObjDispatchObjCmd, (ClientData)svObj, NULL);
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
}

/*

    } 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, -1));
                    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(ckalloc(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(ckalloc(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(
             ClientData 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(
             ClientData 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, -1));
                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
    /*

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

static int
SvKeylsetObjCmd(arg, interp, objc, objv)
    ClientData 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)
    ClientData 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)
    ClientData 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)
    ClientData 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:

#if TCL_MAJOR_VERSION > 8
#define tclSizeT size_t
#elif defined(USE_TCL_STUBS)
#define tclSizeT int
/*  Little hack to eliminate the need for "tclInt.h" here:
    Just copy a small portion of TclIntStubs, just
    enough to make it work */
typedef struct {
    int magic;
    void *hooks;
    void (*dummy[34]) (void); /* dummy entries 0-33, not used */
    int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;

# undef Tcl_GetIntForIndex
# define Tcl_GetIntForIndex(interp, obj, max, ptr) ((threadTclVersion>86)? \
    ((int (*)(Tcl_Interp*,  Tcl_Obj *, int, int*))((&(tclStubsPtr->tcl_PkgProvideEx))[645]))((interp), (obj), (max), (ptr)): \
	tclIntStubsPtr->tclGetIntForIndex((interp), (obj), (max), (ptr)))
#elif TCL_MINOR_VERSION < 7
extern int TclGetIntForIndex(Tcl_Interp*,  Tcl_Obj *, int, int*);

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

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

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

    /*
     * Syntax:

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

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

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

    /*
     * Syntax:

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

static int
SvLappendObjCmd(arg, interp, objc, objv)
    ClientData 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)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{

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

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

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

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

    /*
     * Syntax:

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

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

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

    /*
     * Syntax:

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

static int
SvLlengthObjCmd (arg, interp, objc, objv)
    ClientData 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)
    ClientData 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 *modes[] = {"-exact", "-glob", "-regexp", NULL};

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

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

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

    /*
     * Syntax:

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

static int
SvLsetObjCmd (arg, interp, objc, objv)
    ClientData 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, llen;
    Tcl_Obj *elObj, **newObjList;

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

 *  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;
    tclSizeT index;
    Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;

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