Tcl package Thread source code

 *      Opaque handle of the opened dbm storage.
 *
 * Side effects:
 *      The gdbm file might be created if not found.
 *
 *-----------------------------------------------------------------------------
 */
static void *
ps_gdbm_open(
    const char *path)
{
    GDBM_FILE dbf;
    char *ext;
    Tcl_DString toext;

 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_close(
    void *handle)
{
    gdbm_close((GDBM_FILE)handle);

    return 0;
}

/*

 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_get(
     void *handle,
     const char   *key,
     char **dataptrptr,
     size_t    *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;

 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_first(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;

 *
 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int ps_gdbm_next(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey, dnext;

 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_put(
    void *handle,
    const char   *key,
    char     *dataptr,
    size_t        len)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum drec, dkey;
    int ret;

 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_delete(
    void *handle,
    const char   *key)
{
    GDBM_FILE dbf = (GDBM_FILE)handle;
    datum dkey;
    int ret;

    dkey.dptr  = (char*)key;

 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */
static void
ps_gdbm_free(
    void *handle,
    void        *data)
{
    (void)handle;
    free(data);
}

/*

 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static const char*
ps_gdbm_geterr(
    void *handle)
{
   /*
    * The problem with gdbm interface is that it uses the global
    * gdbm_errno variable which is not per-thread nor mutex
    * protected. This variable is used to reference array of gdbm
    * error text strings. It is very dangeours to use this in the
    * MT-program without proper locking. For this kind of app

 *      Opaque handle for LmdbCtx.
 *
 * Side effects:
 *      The lmdb file might be created if not found.
 *
 *-----------------------------------------------------------------------------
 */
static void *
ps_lmdb_open(
    const char *path)
{
    LmdbCtx ctx;

    char *ext;
    Tcl_DString toext;

 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_close(
    void *handle)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    if (ctx->cur)
    {
        mdb_cursor_close(ctx->cur);
    }
    if (ctx->txn)

 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_get(
     void *handle,
     const char *keyptr,
     char  **dataptrptr,
     size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_first(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

 *
 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int ps_lmdb_next(
    void *handle,
    char   **keyptrptr,
    char  **dataptrptr,
    size_t     *lenptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_put(
    void *handle,
    const char *keyptr,
    char      *dataptr,
    size_t         len)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key, data;

 *      If the key is already associated with some user data, this will
 *      be replaced by the new data chunk.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_delete(
    void *handle,
    const char *keyptr)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    MDB_val key;

    LmdbTxnGet(ctx, LmdbWrite);
    if (ctx->err)

 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */
static void
ps_lmdb_free(
    void *handle,
    void        *data)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    (void)data;

    if (ctx->cur == NULL)
    {

 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static const char*
ps_lmdb_geterr(
    void *handle)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    return mdb_strerror(ctx->err);
}

#endif  /* HAVE_LMDB */

 * core, hard-wire the necessary APIs using the "well-known" offsets into the
 * stubs table.
 */

#if defined(TCL_TIP285) && !TCL_MINIMUM_VERSION(8,6)
# if defined(USE_TCL_STUBS)
#  define TCL_CANCEL_UNWIND 0x100000
#  define Tcl_CancelEval ((int (*)(Tcl_Interp *, Tcl_Obj *, void *, int)) \
     ((&(tclStubsPtr->tcl_PkgProvideEx))[580]))
#  define Tcl_Canceled ((int (*)(Tcl_Interp *, int)) \
     ((&(tclStubsPtr->tcl_PkgProvideEx))[581]))
# else
#  error "Supporting TIP #285 requires USE_TCL_STUBS before Tcl 8.6"
# endif
#endif

typedef struct ThreadCtrl {
    char *script;                         /* Script to execute */
    int flags;                            /* Initial value of the "flags"
                                           * field in ThreadSpecificData */
    Tcl_Condition condWait;               /* Condition variable used to
                                           * sync parent and child threads */
    void *cd;                             /* Opaque ptr to pass to thread */
} ThreadCtrl;

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

typedef struct ThreadEventResult {

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

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

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

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

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

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

/*
 * Miscellaneous functions used within this file
 */

static Tcl_EventDeleteProc ThreadDeleteEvent;

static Tcl_ThreadCreateType
NewThread(void *clientData);

static ThreadSpecificData*
ThreadExistsInner(Tcl_ThreadId id);

static int
ThreadInit(Tcl_Interp *interp);

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

static void
ThreadFreeProc(void *clientData);

static void
ThreadExitProc(void *clientData);

static void
ThreadFreeError(void *clientData);

static void
ListRemove(ThreadSpecificData *tsdPtr);

static void
ListRemoveInner(ThreadSpecificData *tsdPtr);

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCreateObjCmd(
    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;


/*
 *----------------------------------------------------------------------
 *
 * ThreadReserveObjCmd --
 *
 *  This procedure is invoked to process the "thread::preserve" and
 *  "thread::release" Tcl commands. See the user documentation for
 *  details on it does.

 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadReleaseObjCmd(
    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;
    (void)dummy;

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    Init(interp);

 *  Lots.  improper clean up of resources.
 *
 *----------------------------------------------------------------------
 */

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

 *  None.
 *
 *----------------------------------------------------------------------
 */

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

    Init(interp);

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

    ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_INDEX_NONE));

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *

 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadNamesObjCmd(
    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;

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

static int
ThreadSendObjCmd(
    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;

    }
    if (var && (flags & THREAD_SEND_WAIT) == 0) {

        if (thrId == Tcl_GetCurrentThread()) {
            /*
             * FIXME: Do something for callbacks to self
             */
            Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_INDEX_NONE));
            return TCL_ERROR;
        }

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

        clbkPtr = (ThreadClbkData *)ckalloc(sizeof(ThreadClbkData));
        if (cmd) {
            clbkPtr->execProc   = ThreadClbkCommand;
        } else {
            clbkPtr->execProc   = ThreadClbkSetVar;
        }
        clbkPtr->freeProc   = threadSendObjFree;
        clbkPtr->interp     = interp;
        clbkPtr->threadId   = Tcl_GetCurrentThread();
        clbkPtr->clientData = Sv_DuplicateObj(var);
        Tcl_IncrRefCount((Tcl_Obj *)clbkPtr->clientData);
    }

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

    sendPtr = (ThreadSendData *)ckalloc(sizeof(ThreadSendData));
    sendPtr->interp     = NULL; /* Signal to use thread main interp */
    sendPtr->execProc   = ThreadSendEval;
    sendPtr->freeProc   = threadSendFree;
    sendPtr->clientData = memcpy(ckalloc(size), script, size);

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

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

static int
ThreadBroadcastObjCmd(
    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;

     * to the head of the event queue (as out-of-band message).
     */

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

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

 *  Enters the event loop.
 *
 *----------------------------------------------------------------------
 */

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

    Init(interp);

 *  Registers an errorproc.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadErrorProcObjCmd(
    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;
    (void)dummy;

    Init(interp);

    if (objc > 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "?proc?");
        return TCL_ERROR;
    }
    Tcl_MutexLock(&threadMutex);
    if (objc == 1) {
        if (errorProcString) {
            Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, TCL_INDEX_NONE));
        }
    } else {
        if (errorProcString) {
            ckfree(errorProcString);
        }
        proc = Tcl_GetString(objv[1]);
        len = objv[1]->length;

    Tcl_MutexUnlock(&threadMutex);

    return TCL_OK;
}

static void
ThreadFreeError(
    void *dummy
) {
    (void)dummy;

    Tcl_MutexLock(&threadMutex);
    if (errorThreadId != Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        return;

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    Tcl_ThreadId thrId;

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

 *
 * Side effects:
 *  None.
 *----------------------------------------------------------------------
 */
static int
ThreadConfigureObjCmd(
    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. */

 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCancelObjCmd(
    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;

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

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

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

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

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

    return TCL_OK;

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

    if (resultPtr->code == TCL_ERROR) {

    ctrl.condWait = NULL;
    ctrl.flags    = 0;

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

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

        tsdPtr->refCount++;
    }

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

    ThreadGetHandle(thrId, thrHandle);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_INDEX_NONE));

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *

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

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

    /*
     * We need to keep a pointer to the alloc'ed mem of the script
     * we are eval'ing, for the case that we exit during evaluation
     */

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

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

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

        Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
        if (errChannel == NULL) {
            /* Fixes the [#634845] bug; credits to
             * Wojciech Kocjan <wojciech@kocjan.org> */
            return;
        }
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        Tcl_WriteChars(errChannel, "Error from thread ", TCL_INDEX_NONE);
        Tcl_WriteChars(errChannel, buf, TCL_INDEX_NONE);
        Tcl_WriteChars(errChannel, "\n", 1);
        Tcl_WriteChars(errChannel, errorInfo, TCL_INDEX_NONE);
        Tcl_WriteChars(errChannel, "\n", 1);
#endif
    } else {
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        argv[0] = errorProcString;
        argv[1] = buf;
        argv[2] = errorInfo;

        sendPtr = (ThreadSendData *)ckalloc(sizeof(ThreadSendData));
        sendPtr->execProc   = ThreadSendEval;
        sendPtr->freeProc   = threadSendFree;
        sendPtr->clientData = Tcl_Merge(3, argv);
        sendPtr->interp     = NULL;

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

        return 0;
    }

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

    *thrIdArray = (Tcl_ThreadId *)ckalloc(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;

    if (!haveInterpCancel) {
        Tcl_MutexUnlock(&threadMutex);
        Tcl_AppendResult(interp, "not supported with this Tcl version", NULL);
        return TCL_ERROR;
    }

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

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

    Tcl_MutexUnlock(&threadMutex);
    return code;
}

     *      transfer. This allows this thread then to proceed.
     */

    TransferEvent *evPtr;
    TransferResult *resultPtr;

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

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

    if (thrId == Tcl_GetCurrentThread()) {

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

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

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

    ThreadCutChannel(interp, chan);

        int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR);
        Tcl_MutexUnlock(&threadMutex);
        ThreadFreeProc(send);
        if (clbk) {
            ThreadFreeProc(clbk);
        }
        if (inerror) {
            Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", TCL_INDEX_NONE));
        } else {
            ErrorNoSuchThread(interp, thrId);
        }
        return TCL_ERROR;
    }

    /*

	return code;
    }

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

    eventPtr = (ThreadEvent *)ckalloc(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 = (ThreadEventResult *)ckalloc(sizeof(ThreadEventResult));
        resultPtr->done        = NULL;
        resultPtr->result      = NULL;
        resultPtr->errorCode   = NULL;
        resultPtr->errorInfo   = NULL;
        resultPtr->dstThreadId = thrId;
        resultPtr->srcThreadId = Tcl_GetCurrentThread();
        resultPtr->eventPtr    = eventPtr;

            if (dowait) {
                while (resultPtr->result == NULL) {
                    Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
                }
                SpliceOut(resultPtr, resultList);
                Tcl_ConditionFinalize(&resultPtr->done);
                Tcl_DecrRefCount(resultPtr->result);
                ckfree((char *)resultPtr);
            }
        }
    }

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

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

    ThreadSendData *anyPtr = (ThreadSendData *)clientData;

    if (anyPtr) {
        if (anyPtr->clientData) {
            (*anyPtr->freeProc)(anyPtr->clientData);
        }
        ckfree((char *)anyPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadDeleteEvent --

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

    if (eventPtr->proc == ThreadEventProc) {
        /*
         * Regular script event. Just dispose memory
         */

 *  It unblocks anyone that is waiting on a send to this thread.
 *  It cleans up any events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static void
ThreadExitProc(
    void *clientData
) {
    char *threadEvalScript = (char *)clientData;
    const char *diemsg = "target thread died";
    ThreadEventResult *resultPtr, *nextPtr;
    Tcl_ThreadId self = Tcl_GetCurrentThread();
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    TransferResult *tResultPtr, *tNextPtr;

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

    Tcl_MutexLock(&threadMutex);

    /*
     * NaviServer/AOLserver and threadpool threads get started/stopped
     * out of the control of this interface so this is

            /*
             * We are going away. By freeing up the result we signal
             * to the other thread we don't care about the result.
             */

            SpliceOut(resultPtr, resultList);
            ckfree((char *)resultPtr);

        } else if (resultPtr->dstThreadId == self) {

            /*
             * Dang. The target is going away. Unblock the caller.
             * The result string must be dynamically allocated
             * because the main thread is going to call free on it.

             * to the other thread we don't care about the result.
             *
             * This should not happen, as this thread should be in
             * ThreadTransfer at location (*).
             */

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

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

 * Miscelaneous functions used within this file
 */

static int
CreateWorker(Tcl_Interp *interp, ThreadPool *tpoolPtr);

static Tcl_ThreadCreateType
TpoolWorker(void *clientData);

static int
RunStopEvent(Tcl_Event *evPtr, int mask);

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

static ThreadPool*
GetTpool(const char *tpoolName);

static ThreadPool*
GetTpoolUnl(const char *tpoolName);

static void
ThrExitHandler(void *clientData);

static void
AppExitHandler(void *clientData);

static int
TpoolReserve(ThreadPool *tpoolPtr);

static size_t
TpoolRelease(ThreadPool *tpoolPtr);

 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolCreateObjCmd(
    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;

        maxw = minw;
    }

    /*
     * Allocate and initialize thread pool structure
     */

    tpoolPtr = (ThreadPool *)ckalloc(sizeof(ThreadPool));
    memset(tpoolPtr, 0, sizeof(ThreadPool));

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

            Tcl_MutexUnlock(&listMutex);
            return TCL_ERROR;
        }
    }
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));

    return TCL_OK;

 usage:
    Tcl_WrongNumArgs(interp, 1, objv,
                     "?-minworkers count? ?-maxworkers count? "
                     "?-initcmd script? ?-exitcmd script? "

 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolPostObjCmd(
    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;

        }
    }

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

    rPtr = (TpoolResult *)ckalloc(sizeof(TpoolResult));
    memset(rPtr, 0, sizeof(TpoolResult));

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

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolWaitObjCmd(
    void *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;

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolCancelObjCmd(
    void *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;

                if (rPtr->nextPtr != NULL) {
                    rPtr->nextPtr->prevPtr = rPtr->prevPtr;
                } else {
                    tpoolPtr->workTail = rPtr->prevPtr;
                }
                SetResult(NULL, rPtr); /* Just to free the result */
                ckfree(rPtr->script);
                ckfree((char *)rPtr);
                Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]);
                break;
            }
        }
        if (rPtr == NULL && listVar) {
            Tcl_ListObjAppendElement(interp, waitList, wObjv[ii]);
        }

 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static int
TpoolGetObjCmd(
    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_DeleteHashEntry(hPtr);
    Tcl_MutexUnlock(&tpoolPtr->mutex);

    ret = rPtr->retcode;
    SetResult(interp, rPtr);
    ckfree((char *)rPtr);

    if (resVar) {
        Tcl_ObjSetVar2(interp, resVar, NULL, Tcl_GetObjResult(interp), 0);
        Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
        ret = TCL_OK;
    }

 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolReserveObjCmd(
    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;

 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolReleaseObjCmd(
    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;

 *  None.
 *
 *----------------------------------------------------------------------
 */

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

 *  None.
 *
 *----------------------------------------------------------------------
 */

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

 *  None.
 *
 *----------------------------------------------------------------------
 */

static int
TpoolNamesObjCmd(
    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);
    (void)dummy;
    (void)objc;
    (void)objv;

    Tcl_MutexLock(&listMutex);
    for (tpoolPtr = tpoolList; tpoolPtr; tpoolPtr = tpoolPtr->nextPtr) {
        char buf[32];
        sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);
        Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf, TCL_INDEX_NONE));
    }
    Tcl_MutexUnlock(&listMutex);
    Tcl_SetObjResult(interp, listObj);

    return TCL_OK;
}


     * Create new worker thread here. Wait for the thread to start
     * because it's using the ThreadResult arg which is on our stack.
     */

    Tcl_MutexLock(&startMutex);
    if (Tcl_CreateThread(&id, TpoolWorker, &result,
                         TCL_THREAD_STACK_DEFAULT, 0) != TCL_OK) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_INDEX_NONE));
        Tcl_MutexUnlock(&startMutex);
        return TCL_ERROR;
    }
    while(result.retcode == -1) {
        Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL);
    }
    Tcl_MutexUnlock(&startMutex);

 *  None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_ThreadCreateType
TpoolWorker(
    void *clientData
) {
    TpoolResult          *rPtr = (TpoolResult *)clientData;
    ThreadPool       *tpoolPtr = rPtr->tpoolPtr;

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

    }

    /*
     * Tear down the worker
     */

    if (tpoolPtr->exitScript) {
        TpoolEval(interp, tpoolPtr->exitScript, TCL_INDEX_NONE, NULL);
    }

    tpoolPtr->numWorkers--;
    SignalWaiter(tpoolPtr);
    Tcl_MutexUnlock(&tpoolPtr->mutex);

 out:

SetResult(
    Tcl_Interp *interp,
    TpoolResult *rPtr
) {
    if (rPtr->retcode == TCL_ERROR) {
        if (rPtr->errorCode) {
            if (interp) {
                Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_INDEX_NONE));
            }
            ckfree(rPtr->errorCode);
            rPtr->errorCode = NULL;
        }
        if (rPtr->errorInfo) {
            if (interp) {
                Tcl_AddErrorInfo(interp, rPtr->errorInfo);
            }
            ckfree(rPtr->errorInfo);
            rPtr->errorInfo = NULL;
        }
    }
    if (rPtr->result) {
        if (rPtr->result == threadEmptyResult) {
            if (interp) {
                Tcl_ResetResult(interp);
            }
        } else {
            if (interp) {
                Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result, TCL_INDEX_NONE));
            }
            ckfree(rPtr->result);
            rPtr->result = NULL;
        }
    }
}


            if (rPtr->errorInfo) {
                ckfree(rPtr->errorInfo);
            }
            if (rPtr->errorCode) {
                ckfree(rPtr->errorCode);
            }
        }
        ckfree((char *)rPtr);
        Tcl_DeleteHashEntry(hPtr);
        hPtr = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(&tpoolPtr->jobsDone);

    /*
     * Cleanup jobs posted but never completed.
     */

    for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) {
        ckfree(rPtr->script);
        ckfree((char *)rPtr);
    }
    Tcl_MutexFinalize(&tpoolPtr->mutex);
    Tcl_ConditionFinalize(&tpoolPtr->cond);
    ckfree((char *)tpoolPtr);

    return 0;
}

/*
 *----------------------------------------------------------------------
 *

    Tcl_Event *evPtr;

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

    evPtr = (Tcl_Event *)ckalloc(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 = (TpoolWaiter *)ckalloc(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(
    void *clientData
) {
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;

    ckfree((char *)tsdPtr->waitPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * AppExitHandler
 *
 *  Deletes all threadpools on application exit.
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  None.
 *
 *----------------------------------------------------------------------
 */
static void
AppExitHandler(
    void *dummy
) {
    ThreadPool *tpoolPtr;
    (void)dummy;

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

    TCL_CMD(interp, TPOOL_CMD_PREFIX"release",  TpoolReleaseObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"suspend",  TpoolSuspendObjCmd);
    TCL_CMD(interp, TPOOL_CMD_PREFIX"resume",   TpoolResumeObjCmd);

    if (initialized == 0) {
        Tcl_MutexLock(&listMutex);
        if (initialized == 0) {
            Tcl_CreateExitHandler(AppExitHandler, (void *)-1);
            initialized = 1;
        }
        Tcl_MutexUnlock(&listMutex);
    }
    return TCL_OK;
}

 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadMutexObjCmd(
    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;

 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadRWMutexObjCmd(
    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;

    if (opt == (int)w_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        mutexPtr = (SpMutex *)ckalloc(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);

 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadCondObjCmd(
    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;

    if (opt == (int)c_CREATE) {
        Tcl_Obj *nameObj;
        if (objc > 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "create");
            return TCL_ERROR;
        }
        condvPtr = (SpCondv *)ckalloc(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);

 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
ThreadEvalObjCmd(
    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;

    }
    if (!SpMutexFinalize(mutexPtr)) {
        PutMutex(mutexPtr);
        return 0;
    }
    PutMutex(mutexPtr);
    RemoveAnyItem(SP_MUTEX, name, len);
    ckfree((char *)mutexPtr);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *

    }
    if (!SpCondvFinalize(condvPtr)) {
        PutCondv(condvPtr);
        return 0;
    }
    PutCondv(condvPtr);
    RemoveAnyItem(SP_CONDV, name, len);
    ckfree((char *)condvPtr);

    return 1;
}

/*
 *----------------------------------------------------------------------
 *

    Sp_ExclusiveMutex_ *emPtr;
    Tcl_ThreadId thisThread = Tcl_GetCurrentThread();

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

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

    /*

        Sp_ExclusiveMutex_ *emPtr = *(Sp_ExclusiveMutex_**)muxPtr;
        if (emPtr->lock) {
            Tcl_MutexFinalize(&emPtr->lock);
        }
        if (emPtr->mutex) {
            Tcl_MutexFinalize(&emPtr->mutex);
        }
        ckfree((char *)*muxPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_RecursiveMutexLock --

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

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

    rmPtr = *(Sp_RecursiveMutex_**)muxPtr;

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

void
Sp_RecursiveMutexFinalize(Sp_RecursiveMutex *muxPtr)
{
    if (*muxPtr != NULL) {
        Sp_RecursiveMutex_ *rmPtr = *(Sp_RecursiveMutex_**)muxPtr;
        if (rmPtr->lock) {
            Tcl_MutexFinalize(&rmPtr->lock);
        }
        if (rmPtr->cond) {
            Tcl_ConditionFinalize(&rmPtr->cond);
        }
        ckfree((char *)*muxPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Sp_ReadWriteMutexRLock --

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

    if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
        Tcl_MutexLock(&initMutex);
        if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
            *muxPtr = (Sp_ReadWriteMutex_ *)
                ckalloc(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 = (Sp_ReadWriteMutex_ *)
                ckalloc(sizeof(Sp_ReadWriteMutex_));
            memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
        }
        Tcl_MutexUnlock(&initMutex);
    }

    rwPtr = *(Sp_ReadWriteMutex_**)muxPtr;

        }
        if (rwPtr->rcond) {
            Tcl_ConditionFinalize(&rwPtr->rcond);
        }
        if (rwPtr->wcond) {
            Tcl_ConditionFinalize(&rwPtr->wcond);
        }
        ckfree((char *)*muxPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * AnyMutexIsLocked --

static int DeleteArray(Tcl_Interp *, Array*);

static void SvAllocateContainers(Bucket*);
static void SvRegisterStdCommands(void);

#ifdef SV_FINALIZE
static void SvFinalizeContainers(Bucket*);
static void SvFinalize(void *);
#endif /* SV_FINALIZE */

static PsStore* GetPsStore(const char *handle);

static int SvObjDispatchObjCmd(void *arg,
            Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);

/*
 *-----------------------------------------------------------------------------
 *
 * Sv_RegisterCommand --
 *

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

    /*
     * Setup new type structure
     */

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

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

void
Sv_RegisterPsStore(const PsStore *psStorePtr)
{

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

    *psPtr = *psStorePtr;

    /*
     * Plug-in in shared list
     */

            return TCL_BREAK;
        }
    } else {
        Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles);
        LOCK_CONTAINER(*retObj);
        if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) {
            UNLOCK_CONTAINER(*retObj);
            Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", TCL_INDEX_NONE));
            return TCL_BREAK;
        }
        *offset = 2; /* Consumed two arguments: object, cmd */
    }

    return TCL_OK;
}

    case SV_CHANGED:
        if (psPtr) {
            key = (char *)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_INDEX_NONE));
                return TCL_ERROR;
            }
        }
        return TCL_OK;
    }

    return TCL_ERROR; /* Should never be reached */

    Tcl_HashEntry *hPtr;

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

    arrayPtr = (Array *)ckalloc(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);

        if (psPtr->psClose(psPtr->psHandle) == -1) {
            if (interp) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
            }
            return TCL_ERROR;
        }
        ckfree((char *)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
        arrayPtr->psPtr = NULL;
    }
    return TCL_OK;
}

static int
DeleteArray(Tcl_Interp *interp, Array *arrayPtr)

        };
    }
    if (arrayPtr->entryPtr) {
        Tcl_DeleteHashEntry(arrayPtr->entryPtr);
    }

    Tcl_DeleteHashTable(&arrayPtr->vars);
    ckfree((char *)arrayPtr);

    return TCL_OK;
}

/*
 *-----------------------------------------------------------------------------
 *

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

    basePtr = (char *)ckalloc(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;

SvFinalizeContainers(Bucket *bucketPtr)
{
   Container *tmpPtr, *objPtr = bucketPtr->freeCt;

    while (objPtr) {
        if (objPtr->chunkAddr == (char*)objPtr) {
            tmpPtr = objPtr->nextPtr;
            ckfree((char *)objPtr);
            objPtr = tmpPtr;
        } else {
            objPtr = objPtr->nextPtr;
        }
    }
}
#endif /* SV_FINALIZE */

     * Handle the string rep
     */

    if (objPtr->bytes == NULL) {
        dupPtr->bytes = NULL;
    } else if (objPtr->bytes != Sv_tclEmptyStringRep) {
        /* A copy of TclInitStringRep macro */
        dupPtr->bytes = (char *)ckalloc((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';
    }

 *      Depends on the dispatched command
 *
 *-----------------------------------------------------------------------------
 */

static int
SvObjDispatchObjCmd(
                    void *arg,                          /* Pointer to object container. */
                    Tcl_Interp *interp,                 /* Current interpreter. */
                    int objc,                           /* Number of arguments. */
                    Tcl_Obj *const objv[])              /* Argument objects. */
{
    const char *cmdName;
    SvCmdInfo *cmdPtr;

 *      New Tcl command gets created.
 *
 *-----------------------------------------------------------------------------
 */

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 isNew, off, ret, flg;
    char buf[128];
    Tcl_Obj *val = NULL;

     * Format the command name
     */

    sprintf(buf, "::%p", (int*)svObj);
    svObj->aolSpecial = (arg != NULL);
    Tcl_CreateObjCommand(interp, buf, SvObjDispatchObjCmd, svObj, NULL);
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_INDEX_NONE));

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

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvArrayObjCmd(
              void *arg,                          /* Pointer to object container. */
              Tcl_Interp *interp,                 /* Current interpreter. */
              int objc,                           /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i, argx = 0, lobjc = 0, index, ret = TCL_OK;
    const char *arrayName = NULL;
    Array *arrayPtr = NULL;

        }
        if (index == ARESET) {
            ret = FlushArray(arrayPtr);
            if (ret != TCL_OK) {
                if (arrayPtr->psPtr) {
                    PsStore *psPtr = arrayPtr->psPtr;
                    const char *err = psPtr->psError(psPtr->psHandle);
                    Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE));
                }
                goto cmdExit;
            }
        }
        for (i = 0; i < lobjc; i += 2) {
            const char *key = Tcl_GetString(lobjv[i]);
            elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR);

            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 = (char *)Tcl_GetHashKey(&arrayPtr->vars, hPtr);
                if (pattern == NULL || Tcl_StringCaseMatch(key, pattern, 0)) {
                    Tcl_ListObjAppendElement(interp, resObj,
                            Tcl_NewStringObj(key, TCL_INDEX_NONE));
                    if (index == AGET) {
                        elObj = (Container*)Tcl_GetHashValue(hPtr);
                        Tcl_ListObjAppendElement(interp, resObj,
                                Sv_DuplicateObj(elObj->tclObj));
                    }
                }
                hPtr = Tcl_NextHashEntry(&search);

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvNamesObjCmd(
              void *arg,                          /* != NULL if aolSpecial */
              Tcl_Interp *interp,                 /* Current interpreter. */
              int objc,                           /* Number of arguments. */
              Tcl_Obj *const objv[])              /* Argument objects. */
{
    int i;
    const char *pattern = NULL;
    Tcl_HashEntry *hPtr;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvGetObjCmd(
            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;
    Tcl_Obj *res;
    Container *svObj = (Container*)arg;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvExistsObjCmd(
               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;
    Container *svObj = (Container*)arg;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvSetObjCmd(
            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, flg, mode;
    Tcl_Obj *val;
    Container *svObj = (Container*)arg;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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, isNew = 0;
    Tcl_WideInt incrValue = 1, currValue = 0;
    Container *svObj = (Container*)arg;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvPopObjCmd(
            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;
    Tcl_Obj *retObj;
    Array *arrayPtr = NULL;

    retObj = svObj->tclObj;
    svObj->tclObj = NULL;

    if (DeleteContainer(svObj) != TCL_OK) {
        if (svObj->arrayPtr->psPtr) {
            PsStore *psPtr = svObj->arrayPtr->psPtr;
            const char *err = psPtr->psError(psPtr->psHandle);
            Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_INDEX_NONE));
        }
        ret = TCL_ERROR;
        goto cmd_exit;
    }

    if ((objc - off) == 0) {
        Tcl_SetObjResult(interp, retObj);

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

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, isNew;
    const char *toKey;
    Tcl_HashEntry *hPtr;

    }
    if (svObj->entryPtr) {
        char *key = (char *)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_INDEX_NONE));
                return TCL_ERROR;
            }
        }
        Tcl_DeleteHashEntry(svObj->entryPtr);
    }

    svObj->entryPtr = hPtr;

 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

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

    /*
     * Plug-in registered commands in current interpreter
     */

    for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) {
        Tcl_CreateObjCommand(interp, cmdPtr->cmdName, cmdPtr->objProcPtr,
                NULL, NULL);
#ifdef NS_AOLSERVER
        Tcl_CreateObjCommand(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr,
                (void *)(size_t)cmdPtr->aolSpecial, NULL);
#endif
    }

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

 * Side effects
 *    Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */

static void
SvFinalize (void *dummy)
{
    int i;
    SvCmdInfo *cmdPtr;
    RegType *regPtr;

    Tcl_HashEntry *hashPtr;
    Tcl_HashSearch search;

     * Reclaim memory for registered commands
     */

    if (svCmdInfo != NULL) {
        cmdPtr = svCmdInfo;
        while (cmdPtr) {
            SvCmdInfo *tmpPtr = cmdPtr->nextPtr;
            ckfree((char *)cmdPtr);
            cmdPtr = tmpPtr;
        }
        svCmdInfo = NULL;
    }

    /*
     * Reclaim memory for registered object types
     */

    if (regType != NULL) {
        regPtr = regType;
        while (regPtr) {
            RegType *tmpPtr = regPtr->nextPtr;
            ckfree((char *)regPtr);
            regPtr = tmpPtr;
        }
        regType = NULL;
    }

    Tcl_MutexUnlock(&svMutex);

#define SV_ERROR          -1   /* Object may be in incosistent state */

/*
 * Definitions of functions implementing simple key/value
 * persistent storage for shared variable arrays.
 */

typedef void *(ps_open_proc)(const char*);

typedef int (ps_get_proc)   (void *, const char*, char**, size_t*);
typedef int (ps_put_proc)   (void *, const char*, char*, size_t);
typedef int (ps_first_proc) (void *, char**, char**, size_t*);
typedef int (ps_next_proc)  (void *, char**, char**, size_t*);
typedef int (ps_delete_proc)(void *, const char*);
typedef int (ps_close_proc) (void *);
typedef void(ps_free_proc)  (void *, void*);

typedef const char* (ps_geterr_proc)(void *);

/*
 * This structure maintains a bunch of pointers to functions implementing
 * the simple persistence layer for the shared variable arrays.
 */

typedef struct PsStore {
    const char *type;          /* Type identifier of the persistent storage */
    void *psHandle;       /* Handle to the opened storage */
    ps_open_proc   *psOpen;    /* Function to open the persistent key store */
    ps_get_proc    *psGet;     /* Function to retrieve value bound to key */
    ps_put_proc    *psPut;     /* Function to store user key and value */
    ps_first_proc  *psFirst;   /* Function to retrieve the first key/value */
    ps_next_proc   *psNext;    /* Function to retrieve the next key/value */
    ps_delete_proc *psDelete;  /* Function to delete user key and value */
    ps_close_proc  *psClose;   /* Function to close the persistent store */

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpopObjCmd (
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    int ret, off, llen, iarg = 0;
    tclSizeT index = 0;
    Tcl_Obj *elPtr = NULL;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpushObjCmd (
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    int off, ret, flg, llen;
    tclSizeT index = 0;
    Tcl_Obj *args[1];

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLappendObjCmd(
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    int i, ret, flg, off;
    Tcl_Obj *dup;
    Container *svObj = (Container*)arg;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLreplaceObjCmd(
    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;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLrangeObjCmd(
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    int ret, off, llen, nargs, j;
    tclSizeT first, last, i;
    Tcl_Obj **elPtrs, **args;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLinsertObjCmd(
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    int off, ret, flg, llen, nargs, i, j;
    tclSizeT index = 0;
    Tcl_Obj **args;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLlengthObjCmd(
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    int llen, off, ret;
    Container *svObj = (Container*)arg;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsearchObjCmd(
    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;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLindexObjCmd(
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    Tcl_Obj **elPtrs;
    int ret, off, llen;
    tclSizeT index;

 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsetObjCmd(
    void *arg,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
) {
    Tcl_Obj *lPtr;
    int ret, argc, off;
    Container *svObj = (Container*)arg;

!ifndef _RULES_VC
_RULES_VC = 1

# The following macros define the version of the rules.vc nmake build system
# For modifications that are not backward-compatible, you *must* change
# the major version.
RULES_VERSION_MAJOR = 1
RULES_VERSION_MINOR = 6

# The PROJECT macro must be defined by parent makefile.
!if "$(PROJECT)" == ""
!error *** Error: Macro PROJECT not defined! Please define it before including rules.vc
!endif

!if "$(PRJ_PACKAGE_TCLNAME)" == ""

TCLINSTALL	= 1
TCLDIR          = $(_INSTALLDIR)\..
# NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions
# later so the \.. accounts for the /lib
_TCLDIR		= $(_INSTALLDIR)\..
_TCL_H          = $(_TCLDIR)\include\tcl.h

!else # exist(...) && !$(NEED_TCL_SOURCE)

!if [echo _TCLDIR = \> nmakehlp.out] \
   || [nmakehlp -L generic\tcl.h >> nmakehlp.out]
!error *** Could not locate Tcl source directory.
!endif
!include nmakehlp.out
TCLINSTALL      = 0
TCLDIR         = $(_TCLDIR)
_TCL_H          = $(_TCLDIR)\generic\tcl.h

!endif # exist(...) && !$(NEED_TCL_SOURCE)

!endif # TCLDIR

!ifndef _TCL_H
MSG =^
Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h.
!error $(MSG)

NMAKEHLPC = nmakehlp.c

!if !$(DOING_TCL)
!if $(TCLINSTALL)
!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
!else # !$(TCLINSTALL)
!if exist("$(_TCLDIR)\win\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c
!endif
!endif # $(TCLINSTALL)
!endif # !$(DOING_TCL)

!endif # NMAKEHLPC

#           0 -> Use the non-thread allocator.
# UNCHECKED - 1 -> when doing a debug build with symbols, use the release
#           C runtime, 0 -> use the debug C runtime.
# USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking
# CONFIG_CHECK - 1 -> check current build configuration against Tcl
#           configuration (ignored for Tcl itself)
# _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build
#           (CRT library should support this, not needed for Tcl 9.x)
# TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally.
#           (Not needed for Tcl 9.x)
# Further, LINKERFLAGS are modified based on above.

# Default values for all the above
STATIC_BUILD	= 0
TCL_THREADS	= 1
DEBUG		= 0
SYMBOLS		= 0

!if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD)
!message *** Doing staticpkg
TCL_USE_STATIC_PACKAGES	= 1
!else
TCL_USE_STATIC_PACKAGES	= 0
!endif

!if [nmakehlp -f $(OPTS) "nothreads"]
!message *** Compile explicitly for non-threaded tcl
TCL_THREADS = 0
USE_THREAD_ALLOC= 0
!else
TCL_THREADS    = 1
USE_THREAD_ALLOC= 1
!endif

!if "$(TCL_MAJOR_VERSION)" == "8"
!if [nmakehlp -f $(OPTS) "time64bit"]
!message *** Force 64-bit time_t
_USE_64BIT_TIME_T = 1
!endif

!if [nmakehlp -f $(OPTS) "utfmax"]
!message *** Force allowing 4-byte UTF-8 sequences internally
TCL_UTF_MAX = 4
!endif
!endif

# Yes, it's weird that the "symbols" option controls DEBUG and
# the "pdbs" option controls SYMBOLS. That's historical.
!if [nmakehlp -f $(OPTS) "symbols"]
!message *** Doing symbols
DEBUG		= 1

!else
PGO		= 0
!endif

!if [nmakehlp -f $(OPTS) "loimpact"]
!message *** Warning: ignoring option "loimpact" - deprecated on modern Windows.
!endif

# TBD - should get rid of this option
!if [nmakehlp -f $(OPTS) "thrdalloc"]
!message *** Doing thrdalloc
USE_THREAD_ALLOC = 1
!endif

!if [nmakehlp -f $(OPTS) "tclalloc"]
USE_THREAD_ALLOC = 0
!endif

!if [nmakehlp -f $(OPTS) "unchecked"]
!message *** Doing unchecked

TCLLIBNAME	= $(PROJECT)$(VERSION)$(SUFX).$(EXT)
TCLLIB		= $(OUT_DIR)\$(TCLLIBNAME)

TCLSTUBLIBNAME	= $(STUBPREFIX)$(VERSION).lib
TCLSTUBLIB	= $(OUT_DIR)\$(TCLSTUBLIBNAME)
TCL_INCLUDES    = -I"$(WIN_DIR)" -I"$(GENERICDIR)"

!else # !$(DOING_TCL)

!if $(TCLINSTALL) # Building against an installed Tcl

# When building extensions, we need to locate tclsh. Depending on version
# of Tcl we are building against, this may or may not have a "t" suffix.
# Try various possibilities in turn.
TCLSH		= $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe

!endif # TKINSTALL
tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)"

!endif # $(DOING_TK)
!endif # $(DOING_TK) || $(NEED_TK)

# Various output paths
PRJIMPLIB	= $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
PRJLIBNAME	= $(PROJECT)$(VERSION)$(SUFX).$(EXT)
PRJLIB		= $(OUT_DIR)\$(PRJLIBNAME)

PRJSTUBLIBNAME	= $(STUBPREFIX)$(VERSION).lib
PRJSTUBLIB	= $(OUT_DIR)\$(PRJSTUBLIBNAME)

# If extension parent makefile has not defined a resource definition file,
# we will generate one from standard template.

!if $(DOING_TCL) || $(DOING_TK)
LIB_INSTALL_DIR		= $(_INSTALLDIR)\lib
BIN_INSTALL_DIR		= $(_INSTALLDIR)\bin
DOC_INSTALL_DIR		= $(_INSTALLDIR)\doc
!if $(DOING_TCL)
SCRIPT_INSTALL_DIR	= $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
MODULE_INSTALL_DIR	= $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION)
!else # DOING_TK
SCRIPT_INSTALL_DIR	= $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)
!endif
DEMO_INSTALL_DIR	= $(SCRIPT_INSTALL_DIR)\demos
INCLUDE_INSTALL_DIR	= $(_INSTALLDIR)\include

!else # extension other than Tk

# dlllflags - complete linker switches to build DLLs (subsumes lflags)
# conlflags - complete linker switches for console program (subsumes lflags)
# guilflags - complete linker switches for GUI program (subsumes lflags)
# baselibs - minimum Windows libraries required. Parent makefile can
#    define PRJ_LIBS before including rules.rc if additional libs are needed

OPTDEFINES	= /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS
!if $(VCVERSION) >= 1600
OPTDEFINES	= $(OPTDEFINES) /DHAVE_STDINT_H=1
!else
OPTDEFINES	= $(OPTDEFINES) /DMP_NO_STDINT=1
!endif
!if $(VCVERSION) >= 1800
OPTDEFINES	= $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1
!endif

!if $(TCL_MEM_DEBUG)
OPTDEFINES	= $(OPTDEFINES) /DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
OPTDEFINES	= $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS
!endif
!if $(TCL_THREADS) && $(TCL_VERSION) < 87
OPTDEFINES	= $(OPTDEFINES) /DTCL_THREADS=1
!if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87
OPTDEFINES	= $(OPTDEFINES) /DUSE_THREAD_ALLOC=1
!endif
!endif
!if $(STATIC_BUILD)
OPTDEFINES	= $(OPTDEFINES) /DSTATIC_BUILD
!elseif $(TCL_VERSION) > 86
OPTDEFINES	= $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH
!if "$(MACHINE)" == "AMD64"
OPTDEFINES	= $(OPTDEFINES) /DMP_64BIT
!endif
!endif
!if $(TCL_NO_DEPRECATED)
OPTDEFINES	= $(OPTDEFINES) /DTCL_NO_DEPRECATED
!endif

!if $(USE_STUBS)
# Note we do not define USE_TCL_STUBS even when building tk since some
# test targets in tk do not use stubs
!if !$(DOING_TCL)
USE_STUBS_DEFS  = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS
!if $(NEED_TK)
USE_STUBS_DEFS  = $(USE_STUBS_DEFS) /DUSE_TK_STUBS
!endif
!endif
!endif # USE_STUBS

!if !$(DEBUG)
OPTDEFINES	= $(OPTDEFINES) /DNDEBUG
!if $(OPTIMIZING)
OPTDEFINES	= $(OPTDEFINES) /DTCL_CFG_OPTIMIZED
!endif
!endif
!if $(PROFILE)
OPTDEFINES	= $(OPTDEFINES) /DTCL_CFG_PROFILED
!endif
!if "$(MACHINE)" == "AMD64"
OPTDEFINES	= $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
OPTDEFINES	= $(OPTDEFINES) /DNO_STRTOI64=1
!endif

!if "$(TCL_MAJOR_VERSION)" == "8"
!if "$(_USE_64BIT_TIME_T)" == "1"
OPTDEFINES	= $(OPTDEFINES) /D_USE_64BIT_TIME_T=1
!endif
!if "$(TCL_UTF_MAX)" == "4"
OPTDEFINES	= $(OPTDEFINES) /DTCL_UTF_MAX=4
!endif

# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
COMPILERFLAGS  = /D_ATL_XP_TARGETING
!endif

# Like the TEA system only set this non empty for non-Tk extensions
# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME
# so we pass both
!if !$(DOING_TCL) && !$(DOING_TK)
PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
               /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \

### Declarations common to all linker versions
lflags	= -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug)

!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900
lflags	= $(lflags) -nodefaultlib:libucrt.lib
!endif

# Old linkers (Visual C++ 6 in particular) will link for fast loading
# on Win98. Since we do not support Win98 any more, we specify nowin98
# as recommended for NT and later. However, this is only required by
# IX86 on older compilers and only needed if we are not doing a static build.

!if "$(MACHINE)" == "IX86" && !$(STATIC_BUILD)
!if [nmakehlp -l -opt:nowin98 $(LINKER_TESTFLAGS)]
# Align sections for PE size savings.
lflags	= $(lflags) -opt:nowin98
!endif
!endif

dlllflags = $(lflags) -dll
conlflags = $(lflags) -subsystem:console
guilflags = $(lflags) -subsystem:windows

# Libraries that are required for every image.
# Extensions should define any additional libraries with $(PRJ_LIBS)

GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs)
RESCMD  = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \
	    $(TCL_INCLUDES) \
	    /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \
	    /DCOMMAVERSION=$(RCCOMMAVERSION) \
	    /DDOTVERSION=\"$(DOTVERSION)\" \
	    /DVERSION=\"$(VERSION)\" \
	    /DSUFX=\"$(SUFX)\" \
	    /DPROJECT=\"$(PROJECT)\" \
	    /DPRJLIBNAME=\"$(PRJLIBNAME)\"

!ifndef DEFAULT_BUILD_TARGET
DEFAULT_BUILD_TARGET = $(PROJECT)
!endif

!endif

################################################################
# 14. Sanity check selected options against Tcl build options
# When building an extension, certain configuration options should
# match the ones used when Tcl was built. Here we check and
# warn on a mismatch.
!if !$(DOING_TCL)

!if $(TCLINSTALL) # Building against an installed Tcl
!if exist("$(_TCLDIR)\lib\nmake\tcl.nmake")
TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake"
!endif
!else # !$(TCLINSTALL) - building against Tcl source
!if exist("$(OUT_DIR)\tcl.nmake")
TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake"
!endif
!endif # TCLINSTALL

!if $(CONFIG_CHECK)
!ifdef TCLNMAKECONFIG

!if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG)
!message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)).
!endif
!endif

!endif # TCLNMAKECONFIG

!endif # !$(DOING_TCL)


#----------------------------------------------------------
# Display stats being used.
#----------------------------------------------------------

!if !$(DOING_TCL)