Tcl package Thread source code

# TCL_DEFS is not strictly need here, but if you remove it, then you
# must make sure that configure.ac checks for the necessary components
# that your library may use.  TCL_DEFS can actually be a problem if
# you do not compile with a similar machine setup as the Tcl core was
# compiled with.
#DEFS		= $(TCL_DEFS) @DEFS@ $(PKG_CFLAGS)
DEFS		= @DEFS@ $(PKG_CFLAGS) -DTCL_NO_DEPRECATED=1

# Move pkgIndex.tcl to 'BINARIES' var if it is generated in the Makefile
CONFIG_CLEAN_FILES = Makefile pkgIndex.tcl
CLEANFILES	= @CLEANFILES@

CPPFLAGS	= @CPPFLAGS@
LIBS		= @PKG_LIBS@ @LIBS@

#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.69 for thread 2.9a1.
#
#
# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.

subdirs=
MFLAGS=
MAKEFLAGS=

# Identity of this package.
PACKAGE_NAME='thread'
PACKAGE_TARNAME='thread'
PACKAGE_VERSION='2.9a1'
PACKAGE_STRING='thread 2.9a1'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''

# Factoring default headers for most tests.
ac_includes_default="\
#include <stdio.h>
#ifdef HAVE_SYS_TYPES_H

#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
  # Omit some internal or obsolete options to make the list less imposing.
  # This message is too long to be a string in the A/UX 3.1 sh.
  cat <<_ACEOF
\`configure' configures thread 2.9a1 to adapt to many kinds of systems.

Usage: $0 [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.

  cat <<\_ACEOF
_ACEOF
fi

if test -n "$ac_init_help"; then
  case $ac_init_help in
     short | recursive ) echo "Configuration of thread 2.9a1:";;
   esac
  cat <<\_ACEOF

Optional Features:
  --disable-option-checking  ignore unrecognized --enable/--with options
  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]

    cd "$ac_pwd" || { ac_status=$?; break; }
  done
fi

test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
  cat <<\_ACEOF
thread configure 2.9a1
generated by GNU Autoconf 2.69

Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit

  eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno

} # ac_fn_c_check_func
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by thread $as_me 2.9a1, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  $ $0 $@

_ACEOF
exec 5>>config.log
{

if test "${TCL_MAJOR_VERSION}" -ne 8 ; then

    as_fn_error $? "${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.4+
Found config for Tcl ${TCL_VERSION}" "$LINENO" 5
fi
if test "${TCL_MINOR_VERSION}" -lt 4 ; then
    as_fn_error $? "${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.4+
Found config for Tcl ${TCL_VERSION}" "$LINENO" 5
fi

#--------------------------------------------------------------------
# Load the tkConfig.sh file if necessary (Tk extension)
#--------------------------------------------------------------------

#TEA_PATH_TKCONFIG

test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1

cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# Save the log message, to keep $0 and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by thread $as_me 2.9a1, which was
generated by GNU Autoconf 2.69.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@

Report bugs to the package provider."

_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
thread config.status 2.9a1
configured by $0, generated by GNU Autoconf 2.69,
  with options \\"\$ac_cs_config\\"

Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."

# Set your package name and version numbers here.
#
# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided.  These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
#-----------------------------------------------------------------------

AC_INIT([thread], [2.9a1])

#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------

TEA_INIT()

AC_CONFIG_AUX_DIR(tclconfig)

#--------------------------------------------------------------------
# Load the tclConfig.sh file
#--------------------------------------------------------------------

TEA_PATH_TCLCONFIG
TEA_LOAD_TCLCONFIG

if test "${TCL_MAJOR_VERSION}" -ne 8 ; then

    AC_MSG_ERROR([${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.4+
Found config for Tcl ${TCL_VERSION}])
fi
if test "${TCL_MINOR_VERSION}" -lt 4 ; then
    AC_MSG_ERROR([${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.4+
Found config for Tcl ${TCL_VERSION}])
fi

#--------------------------------------------------------------------
# Load the tkConfig.sh file if necessary (Tk extension)
#--------------------------------------------------------------------

#TEA_PATH_TKCONFIG

<p>The package requires Tcl threading extension but can be alternatively
used stand-alone within the AOLserver, a scalable webserver from
America Online.</p>
<p>In a nutshell, a short sample illustrating the usage of the ttrace
with the Tcl threading extension:</p>
<pre class="doctools_example">
    % package require Ttrace
    2.8.2
    % set t1 [thread::create {package require Ttrace; thread::wait}]
    tid0x1802800
    % ttrace::eval {proc test args {return test-[thread::id]}}
    % thread::send $t1 test
    test-tid0x1802800
    % set t2 [thread::create {package require Ttrace; thread::wait}]
    tid0x1804000

[para]
In a nutshell, a short sample illustrating the usage of the ttrace
with the Tcl threading extension:

[example {

    % package require Ttrace
    2.8.2

    % set t1 [thread::create {package require Ttrace; thread::wait}]
    tid0x1802800

    % ttrace::eval {proc test args {return test-[thread::id]}}
    % thread::send $t1 test
    test-tid0x1802800

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

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

    return 0;
}

/*

 * Side effects:
 *      Data returned must be freed by the caller.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_gdbm_get(
     ClientData 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(
    ClientData  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(
    ClientData  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(
    ClientData 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(
    ClientData 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(
    ClientData handle,
    void        *data)
{
    (void)handle;
    free(data);
}

/*

 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */
static const char*
ps_gdbm_geterr(
    ClientData 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 ClientData
ps_lmdb_open(
    const char *path)
{
    LmdbCtx ctx;

    char *ext;
    Tcl_DString toext;

    ctx = ckalloc(sizeof(*ctx));
    if (ctx == NULL)
    {
        return NULL;
    }

    ctx->env = NULL;
    ctx->txn = NULL;
    ctx->cur = NULL;
    ctx->dbi = 0;

    ctx->err = mdb_env_create(&ctx->env);
    if (ctx->err)
    {
        ckfree(ctx);
        return NULL;
    }

    Tcl_DStringInit(&toext);
    ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
    ctx->err = mdb_env_open(ctx->env, ext, MDB_NOSUBDIR|MDB_NOLOCK, 0666);
    Tcl_DStringFree(&toext);

    if (ctx->err)
    {
        ckfree(ctx);
        return NULL;
    }

    return ctx;
}

/*

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

    mdb_env_close(ctx->env);
    ckfree(ctx);

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

 * Side effects:
 *      Data returned must be copied, then psFree must be called.
 *
 *-----------------------------------------------------------------------------
 */
static int
ps_lmdb_get(
     ClientData  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(
    ClientData  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(
    ClientData  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(
    ClientData  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(
    ClientData  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(
    ClientData handle,
    void        *data)
{
    LmdbCtx ctx = (LmdbCtx)handle;
    (void)data;

    if (ctx->cur == NULL)
    {

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

#endif  /* HAVE_LMDB */

#ifndef _TCL_THREAD_INT_H_
#define _TCL_THREAD_INT_H_

#include "tclThread.h"
#include <stdlib.h> /* For strtoul */
#include <string.h> /* For memset and friends */


/*
 * MSVC 8.0 started to mark many standard C library functions depreciated
 * including the *printf family and others. Tell it to shut up.
 * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0)
 */
#if defined(_MSC_VER)

#ifdef NS_AOLSERVER
# include <ns.h>
# if !defined(NS_MAJOR_VERSION) || NS_MAJOR_VERSION < 4
#  error "unsupported NaviServer/AOLserver version"
# endif
#endif

#ifndef TCL_INDEX_NONE
# define TCL_INDEX_NONE	(-1)
#endif

/*
 * Allow for some command names customization.
 * Only thread:: and tpool:: are handled here.
 * Shared variable commands are more complicated.
 * Look into the threadSvCmd.h for more info.
 */

    if ((a)->prevPtr != NULL)                  \
        (a)->prevPtr->nextPtr = (a)->nextPtr;  \
    else                                       \
        (b) = (a)->nextPtr;                    \
    if ((a)->nextPtr != NULL)                  \
        (a)->nextPtr->prevPtr = (a)->prevPtr

/*
 * Version macros
 */

#define TCL_MINIMUM_VERSION(major,minor) \
  ((TCL_MAJOR_VERSION > (major)) || \
    ((TCL_MAJOR_VERSION == (major)) && (TCL_MINOR_VERSION >= (minor))))

/*
 * Utility macros
 */

#define TCL_CMD(a,b,c) \
  if (Tcl_CreateObjCommand((a),(b),(c),NULL, NULL) == NULL) \
    return TCL_ERROR

 */

typedef struct {
    char *modname;
    char *server;
} NsThreadInterpData;

/*
 * Handle binary compatibility regarding
 * Tcl_GetErrorLine in 8.x
 * See Tcl bug #3562640.
 */

MODULE_SCOPE int threadTclVersion;

typedef struct {
    void *unused1;
    void *unused2;
    int errorLine;
} tclInterpType;

#if defined(TCL_TIP285) && defined(USE_TCL_STUBS)
# undef Tcl_GetErrorLine
# define Tcl_GetErrorLine(interp) ((threadTclVersion>85)? \
    ((int (*)(Tcl_Interp *))((&(tclStubsPtr->tcl_PkgProvideEx))[605]))(interp): \
    (((tclInterpType *)(interp))->errorLine))
/* TIP #270 */
# undef Tcl_AddErrorInfo
# define Tcl_AddErrorInfo(interp, msg) ((threadTclVersion>85)? \
    ((void (*)(Tcl_Interp *, Tcl_Obj *))((&(tclStubsPtr->tcl_PkgProvideEx))[574]))(interp, Tcl_NewStringObj(msg, -1)): \
    ((void (*)(Tcl_Interp *, const char *))((&(tclStubsPtr->tcl_PkgProvideEx))[66]))(interp, msg))
/* TIP #337 */
# undef Tcl_BackgroundException
# define Tcl_BackgroundException(interp, result) ((threadTclVersion>85)? \
    ((void (*)(Tcl_Interp *, int))((&(tclStubsPtr->tcl_PkgProvideEx))[609]))(interp, result): \
    ((void (*)(Tcl_Interp *))((&(tclStubsPtr->tcl_PkgProvideEx))[76]))(interp))
#elif !TCL_MINIMUM_VERSION(8,6)
  /* 8.5, 8.4, or less - Emulate access to the error-line information */
# define Tcl_GetErrorLine(interp) (((tclInterpType *)(interp))->errorLine)
#endif

/* When running on Tcl >= 8.7, make sure that Thread still runs when Tcl is compiled
 * with -DTCL_NO_DEPRECATED=1. Stub entries for Tcl_SetIntObj/Tcl_NewIntObj are NULL then.
 * Just use Tcl_SetWideIntObj/Tcl_NewWideIntObj in stead. We don't simply want to use
 * Tcl_SetWideIntObj/Tcl_NewWideIntObj always, since extensions might not expect to
 * get an actual "wideInt".
 */
#if defined(USE_TCL_STUBS)
# undef Tcl_SetIntObj
# define Tcl_SetIntObj(objPtr, value) ((threadTclVersion>86)? \
  ((void (*)(Tcl_Obj *, Tcl_WideInt))((&(tclStubsPtr->tcl_PkgProvideEx))[489]))(objPtr, (int)(value)): \
  ((void (*)(Tcl_Obj *, int))((&(tclStubsPtr->tcl_PkgProvideEx))[61]))(objPtr, value))
# undef Tcl_NewIntObj
# define Tcl_NewIntObj(value) ((threadTclVersion>86)? \
  ((Tcl_Obj * (*)(Tcl_WideInt))((&(tclStubsPtr->tcl_PkgProvideEx))[488]))((int)(value)): \
  ((Tcl_Obj * (*)(int))((&(tclStubsPtr->tcl_PkgProvideEx))[52]))(value))
# undef Tcl_GetUnicodeFromObj
# define Tcl_GetUnicodeFromObj ((((&(tclStubsPtr->tcl_PkgProvideEx))[378]) != ((&(tclStubsPtr->tcl_PkgProvideEx))[434])) ? \
  ((void (*)(Tcl_Obj *, int *))((&(tclStubsPtr->tcl_PkgProvideEx))[434])) : ((void (*)(Tcl_Obj *, int *)) NULL))
#endif

#endif /* _TCL_THREAD_INT_H_ */

 * thread-safe and allow for this datatype to be used from within
 * the thread shared variables implementation.
 *
 * For any questions, contant Zoran Vasiljevic ([email protected])
 *-----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"
#include "threadSvCmd.h"
#include "tclXkeylist.h"
#include <stdarg.h>

#ifdef STATIC_BUILD
#if TCL_MAJOR_VERSION >= 9
/*
 * Static build, Tcl >= 9, compile-time decision to disable T_ROT calls.
 */
#undef Tcl_RegisterObjType
#define Tcl_RegisterObjType(typePtr)    (typePtr)->setFromAnyProc = NULL
#else
/*
 * Static build, Tcl <= 9   --> T_ROT is directly linked, no stubs
 * Nothing needs to be done
 */
#endif
#else /* !STATIC_BUILD */
/*
 * Dynamic build. Assume building with stubs (xx) and make a run-time
 * decision regarding T_ROT.
 * (Ad xx): Should be checked. Without stubs we have to go like static.
 */
#undef Tcl_RegisterObjType
#define Tcl_RegisterObjType(typePtr) if (threadTclVersion<90) { \
    ((void (*)(const Tcl_ObjType *))((&(tclStubsPtr->tcl_PkgProvideEx))[211]))(typePtr); \
} else { \
    (typePtr)->setFromAnyProc = NULL; \
}
#endif /* eof STATIC_BUILD */

/*---------------------------------------------------------------------------*/
/*---------------------------------------------------------------------------*/
/*     Stuff copied verbatim from the rest of TclX to avoid dependencies     */
/*---------------------------------------------------------------------------*/
/*---------------------------------------------------------------------------*/

/*
 * Assert macro for use in TclX.  Some GCCs libraries are missing a function
 * used by their macro, so we define out own.
 */

#ifdef TCLX_DEBUG
# define TclX_Assert(expr) ((expr) ? NULL : \
                            panic("TclX assertion failure: %s:%d \"%s\"\n",\
                            __FILE__, __LINE__, "expr"))
#else
# define TclX_Assert(expr)
#endif

/*
 * 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 ((char *)ckalloc (strlen (sourceStr) + 1), sourceStr))

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

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

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

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

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

/*
 * Type definition.
 */
Tcl_ObjType keyedListType = {
    "keyedList",              /* name */
    FreeKeyedListInternalRep, /* freeIntRepProc */
    DupKeyedListInternalRep,  /* dupIntRepProc */
    UpdateStringOfKeyedList,  /* updateStringProc */
    SetKeyedListFromAny       /* setFromAnyProc */
};


/*-----------------------------------------------------------------------------
 * ValidateKeyedList --
 *   Validate a keyed list (only when TCLX_DEBUG is enabled).
 * Parameters:

 *-----------------------------------------------------------------------------
 */
static keylIntObj_t *
AllocKeyedListIntRep(void)
{
    keylIntObj_t *keylIntPtr;

    keylIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));

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

    return keylIntPtr;
}

static void
FreeKeyedListData(
    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)
        ckfree ((char *) keylIntPtr->entries);
    ckfree ((char *) keylIntPtr);
}

/*-----------------------------------------------------------------------------
 * EnsureKeyedListSpace --
 *   Ensure there is enough room in a keyed list array for a certain number
 * of entries, expanding if necessary.
 *

    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 *)
                ckalloc (newSize * sizeof (keylEntry_t));
        } else {
            keylIntPtr->entries = (keylEntry_t *)
                ckrealloc ((void *) keylIntPtr->entries,
                           newSize * sizeof (keylEntry_t));
        }
        keylIntPtr->arraySize = newSize;
    }

    KEYL_REP_ASSERT (keylIntPtr);
}


static void
DeleteKeyedListEntry (
    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];
    keylIntPtr->numEntries--;

    KEYL_REP_ASSERT (keylIntPtr);

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

    KEYL_REP_ASSERT (srcIntPtr);

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

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

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

    KEYL_REP_ASSERT (srcIntPtr);

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

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

 */
static int
SetKeyedListFromAny(
    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;

    keylIntPtr = AllocKeyedListIntRep ();

    keylIntObj_t *keylIntPtr = (keylIntObj_t *)
        keylPtr->internalRep.twoPtrValue.ptr1;

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

    /*
     * Convert each keyed list entry to a two element list object.  No
     * need to incr/decr ref counts, the list objects will take care of that.

    tmpListObj = Tcl_NewListObj (keylIntPtr->numEntries, listObjv);
    listStr = Tcl_GetString(tmpListObj);
    keylPtr->bytes = ckbinstrdup(listStr, tmpListObj->length);
    keylPtr->length = tmpListObj->length;

    Tcl_DecrRefCount (tmpListObj);
    if (listObjv != staticListObjv)
        ckfree ((void*) listObjv);
}

/*-----------------------------------------------------------------------------
 * TclX_NewKeyedListObj --
 *   Create and initialize a new keyed list object.
 *
 * Returns:

     */
    if (nextSubKey == NULL) {
        if (findIdx < 0) {
            EnsureKeyedListSpace (keylIntPtr, 1);
            findIdx = keylIntPtr->numEntries;
            keylIntPtr->numEntries++;
        } else {
            ckfree (keylIntPtr->entries [findIdx].key);
            Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr);
        }
        keylIntPtr->entries [findIdx].key =
            (char *) ckalloc (keyLen + 1);
        strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
        keylIntPtr->entries [findIdx].key [keyLen] = '\0';
        keylIntPtr->entries [findIdx].valuePtr = valuePtr;
        Tcl_IncrRefCount (valuePtr);
        Tcl_InvalidateStringRep (keylPtr);

        KEYL_REP_ASSERT (keylIntPtr);

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

        KEYL_REP_ASSERT (keylIntPtr);

 *-----------------------------------------------------------------------------
 */
void
TclX_KeyedListInit(
    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) {

 * to be able to plug-in our custom keyed-list
 * object duplicator which produces proper deep
 * copies of the keyed-list objects. The standard
 * one produces shallow copies which are not good
 * for usage in the thread shared variables code.
 */

MODULE_SCOPE Tcl_ObjType keyedListType;

/*
 * Exported for usage in Sv_DuplicateObj. This is slightly
 * modified version of the DupKeyedListInternalRep() function.
 * It does a proper deep-copy of the keyed list object.
 */

/*
 * Provide package version in build contexts which do not provide
 * -DPACKAGE_VERSION, like building a shell with the Thread object
 * files built as part of that shell. Example: basekits.
 */
#ifndef PACKAGE_VERSION
#define PACKAGE_VERSION "2.9a1"
#endif

/*
 * Check if this is Tcl 8.5 or higher.  In that case, we will have the TIP
 * #143 APIs (i.e. interpreter resource limiting) available.
 */

#ifndef TCL_TIP143
# if TCL_MINIMUM_VERSION(8,5)
#  define TCL_TIP143
# endif
#endif

/*
 * If TIP #143 support is enabled and we are compiling against a pre-Tcl 8.5
 * core, hard-wire the necessary APIs using the "well-known" offsets into the
 * stubs table.
 */

#define haveInterpLimit (threadTclVersion>=85)
#if defined(TCL_TIP143) && !TCL_MINIMUM_VERSION(8,5)
# if defined(USE_TCL_STUBS)
#  define Tcl_LimitExceeded ((int (*)(Tcl_Interp *)) \
     ((&(tclStubsPtr->tcl_PkgProvideEx))[524]))
# else
#  error "Supporting TIP #143 requires USE_TCL_STUBS before Tcl 8.5"
# endif
#endif

/*
 * Check if this is Tcl 8.6 or higher.  In that case, we will have the TIP
 * #285 APIs (i.e. asynchronous script cancellation) available.
 */

#define haveInterpCancel (threadTclVersion>=86)
#ifndef TCL_TIP285
# if TCL_MINIMUM_VERSION(8,6)
#  define TCL_TIP285
# endif
#endif

/*
 * If TIP #285 support is enabled and we are compiling against a pre-Tcl 8.6
 * 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 *, ClientData, 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

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

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

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

int threadTclVersion = 0;

/*
 * An instance of the following structure contains all information that is
 * passed into a new thread when the thread is created using either the
 * "thread create" Tcl command or the ThreadCreate() C function.
 */

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

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

typedef struct ThreadEventResult {

    Tcl_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*, ClientData);
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 */
    ClientData clientData;                /* Ptr to pass to send function */
    ThreadSendFree *freeProc;             /* Function to free client data */
     /* ---- */
    Tcl_Interp *interp;                   /* Interp to run the command */
} ThreadSendData;

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

/*
 * Miscellaneous functions used within this file
 */

static Tcl_EventDeleteProc ThreadDeleteEvent;

static Tcl_ThreadCreateType
NewThread(ClientData 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(ClientData clientData);

static void
ThreadExitProc(ClientData clientData);

static void
ThreadFreeError(ClientData clientData);

static void
ListRemove(ThreadSpecificData *tsdPtr);

static void
ListRemoveInner(ThreadSpecificData *tsdPtr);

static void
ErrorNoSuchThread(Tcl_Interp *interp,
                               Tcl_ThreadId thrId);
static void
ThreadCutChannel(Tcl_Interp *interp,
                               Tcl_Channel channel);

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

/*
 * Functions implementing Tcl commands
 */

static Tcl_ObjCmdProc ThreadCreateObjCmd;
static Tcl_ObjCmdProc ThreadReserveObjCmd;

static Tcl_ObjCmdProc ThreadExistsObjCmd;
static Tcl_ObjCmdProc ThreadConfigureObjCmd;
static Tcl_ObjCmdProc ThreadErrorProcObjCmd;
static Tcl_ObjCmdProc ThreadJoinObjCmd;
static Tcl_ObjCmdProc ThreadTransferObjCmd;
static Tcl_ObjCmdProc ThreadDetachObjCmd;
static Tcl_ObjCmdProc ThreadAttachObjCmd;

#ifdef TCL_TIP285
static Tcl_ObjCmdProc ThreadCancelObjCmd;
#endif

static int
ThreadInit(
    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)
#endif
            ) {
            return TCL_ERROR;
        }
        Tcl_ResetResult(interp);
    }

    if (!threadTclVersion) {

        /*
         * Check whether we are running threaded Tcl.
         * Get the current core version to decide whether to use
         * some lately introduced core features or to back-off.
         */

        int major, minor;

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

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

    /*
     * Add shared variable commands
     */

    Sv_Init(interp);

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

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

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

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

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

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

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

static int
ThreadUnwindObjCmd(
    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) {

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

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

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

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

    Init(interp);

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

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

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

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

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

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

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

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

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

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

static void
threadSendFree(void *ptr)
{
    ckfree((char *)ptr);
}

static void
threadSendObjFree(void *ptr)
{
    Tcl_DecrRefCount((Tcl_Obj *)ptr);
}

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

    }
    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", -1));
            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);

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

        /*
         * Leave job's result in passed variable

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

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

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

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

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

static int
ThreadWaitObjCmd(
    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) {

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

static int
ThreadErrorProcObjCmd(
    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?");
        return TCL_ERROR;
    }
    Tcl_MutexLock(&threadMutex);
    if (objc == 1) {
        if (errorProcString) {
            Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, -1));
        }
    } else {
        if (errorProcString) {
            ckfree(errorProcString);
        }
        proc = Tcl_GetString(objv[1]);
        len = objv[1]->length;
        if (len == 0) {
            errorThreadId = NULL;
            errorProcString = NULL;
        } else {
            errorThreadId = Tcl_GetCurrentThread();
            errorProcString = (char *)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
) {
    Tcl_MutexLock(&threadMutex);
    if (errorThreadId != Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
        return;
    }
    ckfree(errorProcString);
    errorThreadId = NULL;
    errorProcString = NULL;
    Tcl_MutexUnlock(&threadMutex);
}

/*
 *----------------------------------------------------------------------

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

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

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

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

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

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

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

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

    Init(interp);

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

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

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

            return TCL_ERROR;
        }
    }

    return TCL_OK;
}

#ifdef TCL_TIP285
/*
 *----------------------------------------------------------------------
 *
 * ThreadCancelObjCmd --
 *
 *  This procedure is invoked to process the "thread::cancel" Tcl
 *  command. See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

        result = Tcl_GetString(objv[ii]);
    } else {
        result = NULL;
    }

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

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

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

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

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

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

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

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

    if (resultPtr->code == TCL_ERROR) {

    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", -1));
        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, -1));

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

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

Tcl_ThreadCreateType
NewThread(
    ClientData 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 <[email protected]> */
            return;
        }
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        Tcl_WriteChars(errChannel, "Error from thread ", -1);
        Tcl_WriteChars(errChannel, buf, -1);
        Tcl_WriteChars(errChannel, "\n", 1);
        Tcl_WriteChars(errChannel, errorInfo, -1);
        Tcl_WriteChars(errChannel, "\n", 1);
#endif
    } else {
        ThreadGetHandle(Tcl_GetCurrentThread(), buf);
        argv[0] = errorProcString;
        argv[1] = buf;
        argv[2] = errorInfo;

        sendPtr = (ThreadSendData*)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;

            return tsdPtr;
        }
    }

    return NULL;
}

#ifdef TCL_TIP285
/*
 *----------------------------------------------------------------------
 *
 * ThreadCancel --
 *
 *    Cancels a script in another thread.
 *

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

    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, -1);
    }

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

    Tcl_MutexUnlock(&threadMutex);
    return code;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * ThreadJoin --
 *
 *  Wait for the exit of a different thread.

     *      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", -1));
    }
    if (Tcl_IsChannelShared(chan)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1));
        return TCL_ERROR;
    }

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

    ThreadCutChannel(interp, chan);

    /*
     * Wrap it into an event.
     */

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

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

    /*
     * Initialize the result fields.

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

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

        return TCL_ERROR;
    }

    if (resultPtr->resultMsg) {
        ckfree(resultPtr->resultMsg);
    }
    ckfree((char *)resultPtr);

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

    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)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1));
        return TCL_ERROR;
    }

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

    ThreadCutChannel(interp, chan);

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

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

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

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

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

    if (found == 0) {

        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", -1));
        } 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;

    /*
     * Return result to caller
     */

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

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

    /*
     * Cleanup
     */

    Tcl_ConditionFinalize(&resultPtr->done);
    Tcl_DecrRefCount(resultPtr->result);
    ckfree((char*)resultPtr);

    return code;
}

/*
 *----------------------------------------------------------------------
 *

         * a script in progress to be canceled or exceed its limit;
         * therefore, check for these conditions if we are able to
         * (i.e. we are running in a high enough version of Tcl).
         */

        Tcl_DoOneEvent(TCL_ALL_EVENTS);

#ifdef TCL_TIP285
        if (haveInterpCancel) {

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

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

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

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

#if defined(TCL_TIP143) || defined(TCL_TIP285)
    /*
     * If the event processing loop above was terminated due to a
     * script in progress being canceled or exceeding its limits,
     * transfer the error to the current interpreter.
     */

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

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

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

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

    ListRemove(tsdPtr);

             * It should immediately exit thereafter. We might get
             * stuck here for long time if user really wants to
             * be absolutely sure that the thread has exited.
             */

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

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

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

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

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

    }
    Tcl_IncrRefCount(resultPtr->result);

    resultPtr->code = code;

    if (errorCode != NULL) {
        size = strlen(errorCode) + 1;
        resultPtr->errorCode = (char *)memcpy(ckalloc(size), errorCode, size);
    } else {
        resultPtr->errorCode = NULL;
    }
    if (errorInfo != NULL) {
        size = strlen(errorInfo) + 1;
        resultPtr->errorInfo = (char *)memcpy(ckalloc(size), errorInfo, size);
    } else {
        resultPtr->errorInfo = NULL;
    }
}

/*
 *----------------------------------------------------------------------

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

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

    ThreadSendData *anyPtr = (ThreadSendData*)clientData;

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

 *  It cleans up our events in the event queue for this thread.
 *
 *----------------------------------------------------------------------
 */
static int
ThreadDeleteEvent(
    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) {

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

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

 * Miscelaneous functions used within this file
 */

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

static Tcl_ThreadCreateType
TpoolWorker(ClientData 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(ClientData clientData);

static void
AppExitHandler(ClientData clientData);

static int
TpoolReserve(ThreadPool *tpoolPtr);

static size_t
TpoolRelease(ThreadPool *tpoolPtr);

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

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

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

    /*
     * Do some consistency checking

        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, -1));

    return TCL_OK;

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

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

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

        }
    }

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

    rPtr->script    = strcpy((char *)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(
    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;
    Tcl_HashEntry *hPtr;

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

                }
                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(
    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_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(
    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;

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

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

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

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

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

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

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

static int
TpoolNamesObjCmd(
    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);
        Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf,-1));
    }
    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", -1));
        Tcl_MutexUnlock(&startMutex);
        return TCL_ERROR;
    }
    while(result.retcode == -1) {
        Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL);
    }
    Tcl_MutexUnlock(&startMutex);

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

static Tcl_ThreadCreateType
TpoolWorker(
    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((char *)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((char *)ckalloc(strlen(errMsg)+1), errMsg);
            Tcl_ConditionNotify(&tpoolPtr->cond);
            Tcl_MutexUnlock(&startMutex);
            goto out;
        }
    }

    /*

            }
        } else if (tpoolPtr->tearDown) {
            PushWork(rPtr, tpoolPtr);
            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 isNew;
            Tcl_SetHashValue(Tcl_CreateHashEntry(&tpoolPtr->jobsDone,
                                                 (void *)(size_t)rPtr->jobId, &isNew),
                             rPtr);
            SignalWaiter(tpoolPtr);
        } else {
            ckfree((char*)rPtr);
        }
    }

    /*
     * Tear down the worker
     */

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

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

 out:

        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 = (char *)ckalloc(1 + strlen(errorCode));
            strcpy(rPtr->errorCode, errorCode);
        }
        if (errorInfo != NULL) {
            rPtr->errorInfo = (char *)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((char *)ckalloc(1 + reslen), result);
    }

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

SetResult(
    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;
        }
        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,-1));
            }
            ckfree(rPtr->result);
            rPtr->result = NULL;
        }
    }
}

/*
 *----------------------------------------------------------------------

    Tcl_MutexUnlock(&tpoolPtr->mutex);

    /*
     * Tear down the pool structure
     */

    if (tpoolPtr->initScript) {
        ckfree(tpoolPtr->initScript);
    }
    if (tpoolPtr->exitScript) {
        ckfree(tpoolPtr->exitScript);
    }

    /*
     * Cleanup completed but not collected jobs
     */

    hPtr = Tcl_FirstHashEntry(&tpoolPtr->jobsDone, &search);
    while (hPtr != NULL) {
        rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr);
        if (rPtr->result && rPtr->result != threadEmptyResult) {
            ckfree(rPtr->result);
        }
        if (rPtr->retcode == TCL_ERROR) {
            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(
    ClientData clientData
) {
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;

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

    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, (ClientData)-1);
            initialized = 1;
        }
        Tcl_MutexUnlock(&listMutex);
    }
    return TCL_OK;
}

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

static int
ThreadMutexObjCmd(
    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[] = {
        "create", "destroy", "lock", "unlock", NULL
    };
    enum options {
        m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK
    };

    /*

            }
        }

        /*
         * Create the requested mutex
         */

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

        /*
         * Generate Tcl name for this mutex

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

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

    static const char *cmdOpts[] = {
        "create", "destroy", "rlock", "wlock", "unlock", NULL
    };
    enum options {
        w_CREATE, w_DESTROY, w_RLOCK, w_WLOCK, w_UNLOCK
    };

    /*

    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(
    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[] = {
        "create", "destroy", "notify", "wait", NULL
    };
    enum options {
        c_CREATE, c_DESTROY, c_NOTIFY, c_WAIT
    };

    /*

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

    Tcl_DecrRefCount(scriptObj);

    if (ret == TCL_ERROR) {
        char msg[32 + TCL_INTEGER_SPACE];
        /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
         * See Tcl bug #3562640 */
        sprintf(msg, "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
        Tcl_AddErrorInfo(interp, msg);
    }

    /*
     * Unlock the mutex.
     */

    if (internal) {

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

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

        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;
    Tcl_MutexLock(&rmPtr->lock);

        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;
    Tcl_MutexLock(&rwPtr->lock);

    /*
     * 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;
    Tcl_MutexLock(&rwPtr->lock);

        }
        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(ClientData);
#endif /* SV_FINALIZE */

static PsStore* GetPsStore(const char *handle);

static int SvObjDispatchObjCmd(ClientData 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", -1));
            return TCL_BREAK;
        }
        *offset = 2; /* Consumed two arguments: object, cmd */
    }

    return TCL_OK;
}

 *
 * Results:
 *      Pointer to the newly allocated persistent storage handler. Caller
 *      must free this block when done with it. If none found, returns NULL,
 *
 * Side effects;
 *      Memory gets allocated. Caller should free the return value of this
 *      function using ckfree().
 *
 *-----------------------------------------------------------------------------
 */

static PsStore*
GetPsStore(const char *handle)
{

     */

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

    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, -1));
                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);

 */

static int
UnbindArray(Tcl_Interp *interp, Array *arrayPtr)
{
    PsStore *psPtr = arrayPtr->psPtr;
    if (arrayPtr->bindAddr) {
        ckfree(arrayPtr->bindAddr);
        arrayPtr->bindAddr = NULL;
    }
    if (psPtr) {
        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(
                    ClientData 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(
            ClientData 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;
    Container *svObj = 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, -1));

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

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

static int
SvArrayObjCmd(
              ClientData 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;
    Tcl_Obj **lobjv = NULL;
    Container *svObj, *elObj = NULL;

    static const char *opts[] = {
        "set",  "reset", "get", "names", "size", "exists", "isbound",
        "bind", "unbind", NULL
    };
    enum options {
        ASET,   ARESET,  AGET,  ANAMES,  ASIZE,  AEXISTS, AISBOUND,
        ABIND,  AUNBIND
    };

        }
        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, -1));
                }
                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, -1));
                    if (index == AGET) {
                        elObj = (Container*)Tcl_GetHashValue(hPtr);
                        Tcl_ListObjAppendElement(interp, resObj,
                                Sv_DuplicateObj(elObj->tclObj));
                    }
                }
                hPtr = Tcl_NextHashEntry(&search);

            ret = TCL_ERROR;
            goto cmdExit;
        }
        if (arrayPtr) {
            Tcl_HashSearch search;
            hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
            arrayPtr->psPtr = psPtr;
            arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl);
            while (hPtr) {
                svObj = (Container *)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((char *)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, &isNew);
                Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
                psPtr->psFree(psPtr->psHandle, val);

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

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

    if (objc < 2) {

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

static int
SvNamesObjCmd(
              ClientData 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;
    Tcl_HashSearch search;
    Tcl_Obj *resObj;

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

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

    /*

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

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

    /*
     * Syntax:

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

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

    /*

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

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

    /*

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

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

    /*
     * Syntax:

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

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

    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,-1));
        }
        ret = TCL_ERROR;
        goto cmd_exit;
    }

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

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

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, isNew;
    const char *toKey;
    Tcl_HashEntry *hPtr;
    Container *svObj = (Container*)arg;

    }
    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, -1));
                return TCL_ERROR;
            }
        }
        Tcl_DeleteHashEntry(svObj->entryPtr);
    }

    svObj->entryPtr = hPtr;

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

static int
SvLockObjCmd(
             ClientData 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;
    Array *arrayPtr = NULL;

    ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT);

    if (ret == TCL_ERROR) {
        char msg[32 + TCL_INTEGER_SPACE];
        /* Next line generates a Deprecation warning when compiled with Tcl 8.6.
         * See Tcl bug #3562640 */
        sprintf(msg, "\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp));
        Tcl_AddErrorInfo(interp, msg);
    }

    /*
     * We unlock the bucket directly, w/o going to Sv_Unlock()
     * since it needs the array which may be unset by the script.
     */

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

    /*

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

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

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

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

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

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

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

    Tcl_HashEntry *hashPtr;
    Tcl_HashSearch search;

                if (bucketPtr->lock) {
                    Sp_RecursiveMutexFinalize(&bucketPtr->lock);
                }
                SvFinalizeContainers(bucketPtr);
                Tcl_DeleteHashTable(&bucketPtr->handles);
                Tcl_DeleteHashTable(&bucketPtr->arrays);
            }
            ckfree((char *)buckets), buckets = NULL;
        }
        buckets = NULL;
        Tcl_MutexUnlock(&bucketsMutex);
    }

    Tcl_MutexLock(&svMutex);

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

#ifndef _SV_H_
#define _SV_H_

#include <tcl.h>
#include <ctype.h>
#include <string.h>


#include "threadSpCmd.h" /* For recursive locks */

/*
 * Uncomment following line to get command-line
 * compatibility with AOLserver nsv_* commands
 */

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

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

typedef ClientData (ps_open_proc)(const char*);

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

typedef const char* (ps_geterr_proc)(ClientData);

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

/*
 * Implementation of most standard Tcl list processing commands
 * suitable for operation on thread shared (list) variables.
 *
 * Copyright (c) 2002 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */


#include "threadSvCmd.h"
#include "threadSvListCmd.h"

#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 TclIntStubs {
    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 struct 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*);
# define Tcl_GetIntForIndex TclGetIntForIndex
#endif


/*
 * Implementation of list commands for shared variables.
 * Most of the standard Tcl list commands are implemented.
 * There are also two new commands: "lpop" and "lpush".
 * Those are very convenient for simple stack operations.
 *

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

static int
SvLpopObjCmd (
    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:
     *          tsv::lpop array key ?index?
     *          $list lpop ?index?

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

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

static int
SvLpushObjCmd (
    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:
     *          tsv::lpush array key element ?index?
     *          $list lpush element ?index?

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

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

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

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

    /*
     * Syntax:
     *          tsv::lreplace array key first last ?element ...?
     *          $list lreplace first last ?element ...?

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

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

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

    ret = Tcl_ListObjReplace(interp, svObj->tclObj, first, ndel, nargs, args);
    if (args) {
        if (ret != TCL_OK) {
            for(i = off + 2, j = 0; i < objc; i++, j++) {
                Tcl_DecrRefCount(args[j]);
            }
        }
        ckfree((char*)args);
    }

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

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

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

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

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

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

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

    Tcl_ResetResult(interp);
    Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args);
    ckfree((char*)args);

 cmd_ok:
    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

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

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

static int
SvLinsertObjCmd(
    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:
     *          tsv::linsert array key index element ?element ...?
     *          $list linsert element ?element ...?

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

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

    ckfree((char*)args);

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

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

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

static int
SvLlengthObjCmd(
    ClientData 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(
    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};
    enum {LS_EXACT, LS_GLOB, LS_REGEXP};

    mode = LS_GLOB;

    /*
     * Syntax:
     *          tsv::lsearch array key ?mode? pattern

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

static int
SvLindexObjCmd(
    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:
     *          tsv::lindex array key index
     *          $list lindex index
     */

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

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

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

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

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

 */

static void
DupListObjShared(
    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;
        return;
    }

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

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

    Tcl_SetListObj(copyPtr, llen, newObjList);

    ckfree((char*)newObjList);
}

/*
 *----------------------------------------------------------------------
 *
 * SvLsetFlat --
 *

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

            break;
        }

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

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

        /*

        interp alias {} [namespace current]::_set     {} tsv::set
        interp alias {} [namespace current]::_unset   {} tsv::unset
    } else {
        error "requires NaviServer/AOLserver or Tcl threading extension"
    }

    # Keep in sync with the Thread package
    package provide Ttrace 2.9a1

    # Package variables
    variable resolvers ""     ; # List of registered resolvers
    variable tracers   ""     ; # List of registered cmd tracers
    variable scripts   ""     ; # List of registered script makers
    variable enables   ""     ; # List of trace-enable callbacks
    variable disables  ""     ; # List of trace-disable callbacks

# -*- tcl -*-
# Tcl package index file, version 1.1
#

if {![package vsatisfies [package provide Tcl] 8.4]} {
    # Pre-8.4 Tcl interps we dont support at all.  Bye!
    # 9.0+ Tcl interps are only supported on 32-bit platforms.

    if {![package vsatisfies [package provide Tcl] 9.0]

	    || ($::tcl_platform(pointerSize) != 4)} {
	return
    }
}

# All Tcl 8.4+ interps can [load] Thread @PACKAGE_VERSION@
#
# For interps that are not thread-enabled, we still call [package ifneeded].
# This is contrary to the usual convention, but is a good idea because we
# cannot imagine any other version of Thread that might succeed in a
# thread-disabled interp.  There's nothing to gain by yielding to other
# competing callers of [package ifneeded Thread].  On the other hand,
# deferring the error has the advantage that a script calling
# [package require Thread] in a thread-disabled interp gets an error message
# about a thread-disabled interp, instead of the message
# "can't find package Thread".

package ifneeded Thread @PACKAGE_VERSION@ [list load [file join $dir @PKG_LIB_FILE@]]

# package Ttrace uses some support machinery.

# In Tcl 8.4 interps we use some older interfaces
if {![package vsatisfies [package provide Tcl] 8.5]} {
    package ifneeded Ttrace @PACKAGE_VERSION@ "
    [list proc @PACKAGE_NAME@_source {dir} {
	if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
		[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
	    source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
	} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
	    source [file join $dir .. lib ttrace.tcl]
	} elseif {[file readable [file join $dir ttrace.tcl]]} {
	    source [file join $dir ttrace.tcl]
	}
	if {[namespace which ::ttrace::update] ne ""} {
	    ::ttrace::update
	}
    }]
    [list @PACKAGE_NAME@_source $dir]
    [list rename @PACKAGE_NAME@_source {}]"
    return
}

# In Tcl 8.5+ interps; use [::apply]

package ifneeded Ttrace @PACKAGE_VERSION@ [list ::apply {{dir} {
    if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
	[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
	source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
    } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
	source [file join $dir .. lib ttrace.tcl]

#
# Copyright (c) 2002 by Zoran Vasiljevic.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -----------------------------------------------------------------------------

package require Tcl    8.4
package require Thread 2.5

namespace eval cmdsrv {
    variable data; # Stores global configuration options
}

#
# cmdsrv::create --

#
# Copyright (c) 2002 by Zoran Vasiljevic.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -----------------------------------------------------------------------------

package require Tcl    8.4
package require Thread 2.5

#
# Modify the following in order to load the
# example Tcl implementation of threadpools.
# Per default, the C-level threadpool is used.
#

#
# Copyright (c) 2002 by Zoran Vasiljevic.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -----------------------------------------------------------------------------


package require Thread 2.5
set thisScript [info script]

namespace eval tpool {

    variable afterevent "" ; # Idle timer event for worker threads
    variable result        ; # Stores result from the worker thread
    variable waiter        ; # Waits for an idle worker thread

# remember to change configure.ac as well when these change
# (then re-autoconf)

PACKAGE_MAJOR	= 2
PACKAGE_MINOR	= 9
PACKAGE_VERSION	= "2.9a1"