In a nutshell, a short sample illustrating the usage of the ttrace with the Tcl threading extension:
% package require Ttrace
- 2.8.2
+ 2.8.1
% 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
Index: doc/ttrace.man
==================================================================
--- doc/ttrace.man
+++ doc/ttrace.man
@@ -19,11 +19,11 @@
with the Tcl threading extension:
[example {
% package require Ttrace
- 2.8.2
+ 2.8.1
% set t1 [thread::create {package require Ttrace; thread::wait}]
tid0x1802800
% ttrace::eval {proc test args {return test-[thread::id]}}
Index: generic/psGdbm.c
==================================================================
--- generic/psGdbm.c
+++ generic/psGdbm.c
@@ -81,11 +81,11 @@
* Side effects:
* The gdbm file might be created if not found.
*
*-----------------------------------------------------------------------------
*/
-static ClientData
+static void *
ps_gdbm_open(
const char *path)
{
GDBM_FILE dbf;
char *ext;
@@ -114,11 +114,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_close(
- ClientData handle)
+ void *handle)
{
gdbm_close((GDBM_FILE)handle);
return 0;
}
@@ -139,11 +139,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_get(
- ClientData handle,
+ void *handle,
const char *key,
char **dataptrptr,
size_t *lenptr)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
@@ -179,11 +179,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_first(
- ClientData handle,
+ void *handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
@@ -220,11 +220,11 @@
* Data returned must be freed by the caller.
*
*-----------------------------------------------------------------------------
*/
static int ps_gdbm_next(
- ClientData handle,
+ void *handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
@@ -268,11 +268,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_put(
- ClientData handle,
+ void *handle,
const char *key,
char *dataptr,
size_t len)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
@@ -310,11 +310,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_gdbm_delete(
- ClientData handle,
+ void *handle,
const char *key)
{
GDBM_FILE dbf = (GDBM_FILE)handle;
datum dkey;
int ret;
@@ -345,11 +345,11 @@
*
*-----------------------------------------------------------------------------
*/
static void
ps_gdbm_free(
- ClientData handle,
+ void *handle,
void *data)
{
(void)handle;
free(data);
}
@@ -370,11 +370,11 @@
*
*-----------------------------------------------------------------------------
*/
static const char*
ps_gdbm_geterr(
- ClientData handle)
+ void *handle)
{
/*
* The problem with gdbm interface is that it uses the global
* gdbm_errno variable which is not per-thread nor mutex
* protected. This variable is used to reference array of gdbm
Index: generic/psLmdb.c
==================================================================
--- generic/psLmdb.c
+++ generic/psLmdb.c
@@ -148,20 +148,20 @@
* Side effects:
* The lmdb file might be created if not found.
*
*-----------------------------------------------------------------------------
*/
-static ClientData
+static void *
ps_lmdb_open(
const char *path)
{
LmdbCtx ctx;
char *ext;
Tcl_DString toext;
- ctx = ckalloc(sizeof(*ctx));
+ ctx = Tcl_Alloc(sizeof(*ctx));
if (ctx == NULL)
{
return NULL;
}
@@ -171,11 +171,11 @@
ctx->dbi = 0;
ctx->err = mdb_env_create(&ctx->env);
if (ctx->err)
{
- ckfree(ctx);
+ Tcl_Free(ctx);
return NULL;
}
Tcl_DStringInit(&toext);
ext = Tcl_UtfToExternalDString(NULL, path, strlen(path), &toext);
@@ -182,11 +182,11 @@
ctx->err = mdb_env_open(ctx->env, ext, MDB_NOSUBDIR|MDB_NOLOCK, 0666);
Tcl_DStringFree(&toext);
if (ctx->err)
{
- ckfree(ctx);
+ Tcl_Free(ctx);
return NULL;
}
return ctx;
}
@@ -206,11 +206,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_close(
- ClientData handle)
+ void *handle)
{
LmdbCtx ctx = (LmdbCtx)handle;
if (ctx->cur)
{
mdb_cursor_close(ctx->cur);
@@ -219,11 +219,11 @@
{
LmdbTxnAbort(ctx);
}
mdb_env_close(ctx->env);
- ckfree(ctx);
+ Tcl_Free(ctx);
return 0;
}
/*
@@ -242,11 +242,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_get(
- ClientData handle,
+ void *handle,
const char *keyptr,
char **dataptrptr,
size_t *lenptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
@@ -297,11 +297,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_first(
- ClientData handle,
+ void *handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
@@ -350,11 +350,11 @@
* Data returned must be copied, then psFree must be called.
*
*-----------------------------------------------------------------------------
*/
static int ps_lmdb_next(
- ClientData handle,
+ void *handle,
char **keyptrptr,
char **dataptrptr,
size_t *lenptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
@@ -393,11 +393,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_put(
- ClientData handle,
+ void *handle,
const char *keyptr,
char *dataptr,
size_t len)
{
LmdbCtx ctx = (LmdbCtx)handle;
@@ -445,11 +445,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
ps_lmdb_delete(
- ClientData handle,
+ void *handle,
const char *keyptr)
{
LmdbCtx ctx = (LmdbCtx)handle;
MDB_val key;
@@ -495,11 +495,11 @@
*
*-----------------------------------------------------------------------------
*/
static void
ps_lmdb_free(
- ClientData handle,
+ void *handle,
void *data)
{
LmdbCtx ctx = (LmdbCtx)handle;
(void)data;
@@ -525,11 +525,11 @@
*
*-----------------------------------------------------------------------------
*/
static const char*
ps_lmdb_geterr(
- ClientData handle)
+ void *handle)
{
LmdbCtx ctx = (LmdbCtx)handle;
return mdb_strerror(ctx->err);
}
Index: generic/tclThreadInt.h
==================================================================
--- generic/tclThreadInt.h
+++ generic/tclThreadInt.h
@@ -16,10 +16,11 @@
#define _TCL_THREAD_INT_H_
#include "tclThread.h"
#include /* For strtoul */
#include /* For memset and friends */
+#include /* For va_list */
/*
* 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)
@@ -54,14 +55,10 @@
# 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.
@@ -104,18 +101,10 @@
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) \
@@ -138,60 +127,12 @@
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_ */
Index: generic/tclXkeylist.c
==================================================================
--- generic/tclXkeylist.c
+++ generic/tclXkeylist.c
@@ -23,42 +23,14 @@
*
* For any questions, contant Zoran Vasiljevic (zoran@archiware.com)
*-----------------------------------------------------------------------------
*/
-#include "tclThreadInt.h"
#include "threadSvCmd.h"
#include "tclXkeylist.h"
#include
-#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 */
/*---------------------------------------------------------------------------*/
/*---------------------------------------------------------------------------*/
@@ -75,19 +47,19 @@
#else
# define TclX_Assert(expr)
#endif
/*
- * Macro that behaves like strdup, only uses ckalloc. Also macro that does the
+ * Macro that behaves like strdup, only uses Tcl_Alloc. Also macro that does the
* same with a string that might contain zero bytes,
*/
#define ckstrdup(sourceStr) \
- (strcpy ((char *)ckalloc (strlen (sourceStr) + 1), sourceStr))
+ (strcpy ((char *)Tcl_Alloc (strlen (sourceStr) + 1), sourceStr))
#define ckbinstrdup(sourceStr, length) \
- ((char *) memcpy ((char *)ckalloc (length + 1), sourceStr, length + 1))
+ ((char *) memcpy ((char *)Tcl_Alloc (length + 1), sourceStr, length + 1))
/*
* Used to return argument messages by most commands.
*/
static const char *tclXWrongArgs = "wrong # args: ";
@@ -314,34 +286,34 @@
Tcl_Obj *const objv[]);
static int
Tcl_KeylsetObjCmd(void *clientData,
Tcl_Interp *interp,
- int objc,
+ int objc,
Tcl_Obj *const objv[]);
static int
Tcl_KeyldelObjCmd(void *clientData,
Tcl_Interp *interp,
- int objc,
+ int objc,
Tcl_Obj *const objv[]);
static int
Tcl_KeylkeysObjCmd(void *clientData,
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[]);
+ int objc,
+ Tcl_Obj *const objv[]);
/*
* Type definition.
*/
-Tcl_ObjType keyedListType = {
+const Tcl_ObjType keyedListType = {
"keyedList", /* name */
FreeKeyedListInternalRep, /* freeIntRepProc */
DupKeyedListInternalRep, /* dupIntRepProc */
UpdateStringOfKeyedList, /* updateStringProc */
- SetKeyedListFromAny /* setFromAnyProc */
+ NULL /* setFromAnyProc */
};
/*-----------------------------------------------------------------------------
* ValidateKeyedList --
@@ -438,11 +410,11 @@
static keylIntObj_t *
AllocKeyedListIntRep(void)
{
keylIntObj_t *keylIntPtr;
- keylIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));
+ keylIntPtr = (keylIntObj_t *)Tcl_Alloc(sizeof(keylIntObj_t));
keylIntPtr->arraySize = 0;
keylIntPtr->numEntries = 0;
keylIntPtr->entries = NULL;
@@ -462,16 +434,16 @@
keylIntObj_t *keylIntPtr
) {
int idx;
for (idx = 0; idx < keylIntPtr->numEntries ; idx++) {
- ckfree (keylIntPtr->entries [idx].key);
- Tcl_DecrRefCount (keylIntPtr->entries [idx].valuePtr);
+ Tcl_Free(keylIntPtr->entries[idx].key);
+ Tcl_DecrRefCount (keylIntPtr->entries[idx].valuePtr);
}
if (keylIntPtr->entries != NULL)
- ckfree ((char *) keylIntPtr->entries);
- ckfree ((char *) keylIntPtr);
+ Tcl_Free(keylIntPtr->entries);
+ Tcl_Free(keylIntPtr);
}
/*-----------------------------------------------------------------------------
* EnsureKeyedListSpace --
* Ensure there is enough room in a keyed list array for a certain number
@@ -493,15 +465,15 @@
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));
+ Tcl_Alloc(newSize * sizeof(keylEntry_t));
} else {
keylIntPtr->entries = (keylEntry_t *)
- ckrealloc ((void *) keylIntPtr->entries,
- newSize * sizeof (keylEntry_t));
+ Tcl_Realloc(keylIntPtr->entries,
+ newSize * sizeof(keylEntry_t));
}
keylIntPtr->arraySize = newSize;
}
KEYL_REP_ASSERT (keylIntPtr);
@@ -521,11 +493,11 @@
keylIntObj_t *keylIntPtr,
int entryIdx
) {
int idx;
- ckfree (keylIntPtr->entries [entryIdx].key);
+ Tcl_Free(keylIntPtr->entries [entryIdx].key);
Tcl_DecrRefCount (keylIntPtr->entries [entryIdx].valuePtr);
for (idx = entryIdx; idx < keylIntPtr->numEntries - 1; idx++)
keylIntPtr->entries [idx] = keylIntPtr->entries [idx + 1];
keylIntPtr->numEntries--;
@@ -679,15 +651,15 @@
keylIntObj_t *copyIntPtr;
int idx;
KEYL_REP_ASSERT (srcIntPtr);
- copyIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));
+ copyIntPtr = (keylIntObj_t *)Tcl_Alloc(sizeof(keylIntObj_t));
copyIntPtr->arraySize = srcIntPtr->arraySize;
copyIntPtr->numEntries = srcIntPtr->numEntries;
copyIntPtr->entries = (keylEntry_t *)
- ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t));
+ Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t));
for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
copyIntPtr->entries [idx].key =
ckstrdup (srcIntPtr->entries [idx].key);
copyIntPtr->entries [idx].valuePtr = srcIntPtr->entries [idx].valuePtr;
@@ -721,15 +693,15 @@
keylIntObj_t *copyIntPtr;
int idx;
KEYL_REP_ASSERT (srcIntPtr);
- copyIntPtr = (keylIntObj_t *) ckalloc (sizeof (keylIntObj_t));
+ copyIntPtr = (keylIntObj_t *)Tcl_Alloc(sizeof(keylIntObj_t));
copyIntPtr->arraySize = srcIntPtr->arraySize;
copyIntPtr->numEntries = srcIntPtr->numEntries;
copyIntPtr->entries = (keylEntry_t *)
- ckalloc (copyIntPtr->arraySize * sizeof (keylEntry_t));
+ Tcl_Alloc(copyIntPtr->arraySize * sizeof(keylEntry_t));
for (idx = 0; idx < srcIntPtr->numEntries ; idx++) {
copyIntPtr->entries [idx].key =
ckstrdup (srcIntPtr->entries [idx].key);
copyIntPtr->entries [idx].valuePtr =
@@ -757,11 +729,12 @@
SetKeyedListFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr
) {
keylIntObj_t *keylIntPtr;
- int idx, objc;
+ int idx;
+ int objc;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements (interp, objPtr, &objc, &objv) != TCL_OK)
return TCL_ERROR;
@@ -813,12 +786,12 @@
/*
* 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 *));
+ listObjv = (Tcl_Obj **)
+ Tcl_Alloc(keylIntPtr->numEntries * sizeof(Tcl_Obj *));
} else {
listObjv = staticListObjv;
}
/*
@@ -839,11 +812,11 @@
keylPtr->bytes = ckbinstrdup(listStr, tmpListObj->length);
keylPtr->length = tmpListObj->length;
Tcl_DecrRefCount (tmpListObj);
if (listObjv != staticListObjv)
- ckfree ((void*) listObjv);
+ Tcl_Free(listObjv);
}
/*-----------------------------------------------------------------------------
* TclX_NewKeyedListObj --
* Create and initialize a new keyed list object.
@@ -969,15 +942,15 @@
if (findIdx < 0) {
EnsureKeyedListSpace (keylIntPtr, 1);
findIdx = keylIntPtr->numEntries;
keylIntPtr->numEntries++;
} else {
- ckfree (keylIntPtr->entries [findIdx].key);
+ Tcl_Free(keylIntPtr->entries [findIdx].key);
Tcl_DecrRefCount (keylIntPtr->entries [findIdx].valuePtr);
}
- keylIntPtr->entries [findIdx].key =
- (char *) ckalloc (keyLen + 1);
+ keylIntPtr->entries [findIdx].key = (char *)
+ Tcl_Alloc(keyLen + 1);
strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
keylIntPtr->entries [findIdx].key [keyLen] = '\0';
keylIntPtr->entries [findIdx].valuePtr = valuePtr;
Tcl_IncrRefCount (valuePtr);
Tcl_InvalidateStringRep (keylPtr);
@@ -1011,12 +984,12 @@
Tcl_DecrRefCount (newKeylPtr);
return TCL_ERROR;
}
EnsureKeyedListSpace (keylIntPtr, 1);
findIdx = keylIntPtr->numEntries++;
- keylIntPtr->entries [findIdx].key =
- (char *) ckalloc (keyLen + 1);
+ keylIntPtr->entries [findIdx].key = (char *)
+ Tcl_Alloc(keyLen + 1);
strncpy (keylIntPtr->entries [findIdx].key, key, keyLen);
keylIntPtr->entries [findIdx].key [keyLen] = '\0';
keylIntPtr->entries [findIdx].valuePtr = newKeylPtr;
Tcl_IncrRefCount (newKeylPtr);
Tcl_InvalidateStringRep (keylPtr);
@@ -1444,11 +1417,10 @@
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);
Index: generic/tclXkeylist.h
==================================================================
--- generic/tclXkeylist.h
+++ generic/tclXkeylist.h
@@ -38,11 +38,11 @@
* 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;
+MODULE_SCOPE const 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.
Index: generic/threadCmd.c
==================================================================
--- generic/threadCmd.c
+++ generic/threadCmd.c
@@ -26,68 +26,11 @@
* 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
+#define PACKAGE_VERSION "3.0a1"
#endif
/*
* Access to the list of threads and to the thread send results
* (defined below) is guarded by this mutex.
@@ -147,12 +90,10 @@
* 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.
*/
@@ -161,11 +102,11 @@
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 */
+ void *cd; /* Opaque ptr to pass to thread */
} ThreadCtrl;
/*
* Structure holding result of the command executed in target thread.
*/
@@ -201,11 +142,11 @@
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 int (ThreadSendProc) (Tcl_Interp*, void *);
typedef void (ThreadSendFree) (void *);
static ThreadSendProc ThreadSendEval; /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar; /* Sets the named variable */
static ThreadSendProc ThreadClbkCommand; /* Sets the named variable */
@@ -218,19 +159,19 @@
* 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 */
+ void *clientData; /* Ptr to pass to send function */
ThreadSendFree *freeProc; /* Function to free client data */
/* ---- */
Tcl_Interp *interp; /* Interp to run the command */
} ThreadSendData;
typedef struct ThreadClbkData {
ThreadSendProc *execProc; /* The callback function */
- ClientData clientData; /* Ptr to pass to clbk function */
+ void *clientData; /* Ptr to pass to clbk function */
ThreadSendFree *freeProc; /* Function to free client data */
/* ---- */
Tcl_Interp *interp; /* Interp to run the command */
Tcl_ThreadId threadId; /* Thread where to post callback */
ThreadEventResult result; /* Returns result asynchronously */
@@ -286,11 +227,11 @@
*/
static Tcl_EventDeleteProc ThreadDeleteEvent;
static Tcl_ThreadCreateType
-NewThread(ClientData clientData);
+NewThread(void *clientData);
static ThreadSpecificData*
ThreadExistsInner(Tcl_ThreadId id);
static int
@@ -341,17 +282,17 @@
Tcl_ThreadId **thrIdArray);
static void
ThreadErrorProc(Tcl_Interp *interp);
static void
-ThreadFreeProc(ClientData clientData);
+ThreadFreeProc(void *clientData);
static void
-ThreadExitProc(ClientData clientData);
+ThreadExitProc(void *clientData);
static void
-ThreadFreeError(ClientData clientData);
+ThreadFreeError(void *clientData);
static void
ListRemove(ThreadSpecificData *tsdPtr);
static void
@@ -393,17 +334,15 @@
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
*/
@@ -422,54 +361,36 @@
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 8.6 interps are only supported on 32-bit machines.
+ * Lower than that is never supported. Bye!
+ */
+ const char *ver = (sizeof(size_t) == sizeof(int))? "8.6-": "9.0";
+
+ if (!((Tcl_InitStubs)(interp, ver, (TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16),
+ TCL_STUB_MAGIC))) {
+ return TCL_ERROR;
+ }
+
+ if (threadMutex == NULL){
+ Tcl_MutexLock(&threadMutex);
+ if (threadMutex == NULL){
+ /* If threadMutex==NULL here, it means that Tcl_MutexLock() is
+ * a dummy function, which is the case in unthreaded Tcl */
+ const char *msg = "Tcl core wasn't compiled for threading";
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+ return TCL_ERROR;
+ }
+ 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);
@@ -485,13 +406,11 @@
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
*/
@@ -591,11 +510,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadCreateObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int argc, rsrv = 0;
@@ -642,13 +561,12 @@
*----------------------------------------------------------------------
*
* 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.
+ * "thread::release" Tcl commands. See the user documentation for
+ * details on it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
@@ -657,11 +575,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadReserveObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId = NULL;
@@ -699,11 +617,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadReleaseObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int wait = 0;
@@ -748,11 +666,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadUnwindObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Init(interp);
@@ -783,11 +701,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadExitObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int status = 666;
@@ -829,11 +747,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadIdObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char thrHandle[THREAD_HNDLMAXLEN];
@@ -844,11 +762,11 @@
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_AUTO_LENGTH));
return TCL_OK;
}
/*
@@ -870,11 +788,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadNamesObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ii, length;
@@ -906,11 +824,11 @@
result = Tcl_DStringValue(&threadNames);
Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length));
Tcl_DStringFree(&threadNames);
- ckfree((char*)thrIdArray);
+ Tcl_Free(thrIdArray);
return TCL_OK;
}
/*
@@ -931,11 +849,11 @@
*/
static void
threadSendFree(void *ptr)
{
- ckfree((char *)ptr);
+ Tcl_Free(ptr);
}
static void
threadSendObjFree(void *ptr)
{
@@ -942,11 +860,11 @@
Tcl_DecrRefCount((Tcl_Obj *)ptr);
}
static int
ThreadSendObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
size_t size;
@@ -1002,21 +920,21 @@
if (thrId == Tcl_GetCurrentThread()) {
/*
* FIXME: Do something for callbacks to self
*/
- Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_AUTO_LENGTH));
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));
+ clbkPtr = (ThreadClbkData *)Tcl_Alloc(sizeof(ThreadClbkData));
if (cmd) {
clbkPtr->execProc = ThreadClbkCommand;
} else {
clbkPtr->execProc = ThreadClbkSetVar;
}
@@ -1029,15 +947,15 @@
/*
* Prepare job record for the target thread
*/
- sendPtr = (ThreadSendData*)ckalloc(sizeof(ThreadSendData));
+ sendPtr = (ThreadSendData *)Tcl_Alloc(sizeof(ThreadSendData));
sendPtr->interp = NULL; /* Signal to use thread main interp */
sendPtr->execProc = ThreadSendEval;
sendPtr->freeProc = threadSendFree;
- sendPtr->clientData = memcpy(ckalloc(size), script, size);
+ sendPtr->clientData = memcpy(Tcl_Alloc(size), script, size);
ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags);
if (var && (flags & THREAD_SEND_WAIT)) {
@@ -1078,11 +996,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadBroadcastObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ii, nthreads;
@@ -1134,17 +1052,17 @@
for (ii = 0; ii < nthreads; ii++) {
if (thrIdArray[ii] == Tcl_GetCurrentThread()) {
continue; /* Do not broadcast self */
}
- sendPtr = (ThreadSendData*)ckalloc(sizeof(ThreadSendData));
+ sendPtr = (ThreadSendData *)Tcl_Alloc(sizeof(ThreadSendData));
*sendPtr = job;
- sendPtr->clientData = memcpy(ckalloc(size), script, size);
+ sendPtr->clientData = memcpy(Tcl_Alloc(size), script, size);
ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD);
}
- ckfree((char*)thrIdArray);
+ Tcl_Free(thrIdArray);
Tcl_ResetResult(interp);
return TCL_OK;
}
@@ -1165,11 +1083,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadWaitObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Init(interp);
@@ -1201,11 +1119,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadErrorProcObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
size_t len;
@@ -1218,24 +1136,24 @@
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
if (objc == 1) {
if (errorProcString) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(errorProcString, TCL_AUTO_LENGTH));
}
} else {
if (errorProcString) {
- ckfree(errorProcString);
+ Tcl_Free(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));
+ errorProcString = (char *)Tcl_Alloc(1+strlen(proc));
strcpy(errorProcString, proc);
Tcl_DeleteThreadExitHandler(ThreadFreeError, NULL);
Tcl_CreateThreadExitHandler(ThreadFreeError, NULL);
}
}
@@ -1244,18 +1162,18 @@
return TCL_OK;
}
static void
ThreadFreeError(
- ClientData clientData
+ void *clientData
) {
Tcl_MutexLock(&threadMutex);
if (errorThreadId != Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
return;
}
- ckfree(errorProcString);
+ Tcl_Free(errorProcString);
errorThreadId = NULL;
errorProcString = NULL;
Tcl_MutexUnlock(&threadMutex);
}
@@ -1276,11 +1194,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadJoinObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId;
@@ -1320,11 +1238,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadTransferObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
@@ -1370,11 +1288,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadDetachObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_Channel chan;
@@ -1415,11 +1333,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadAttachObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char *chanName;
@@ -1460,11 +1378,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadExistsObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId;
@@ -1500,11 +1418,11 @@
* None.
*----------------------------------------------------------------------
*/
static int
ThreadConfigureObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char *option, *value;
@@ -1552,11 +1470,10 @@
}
return TCL_OK;
}
-#ifdef TCL_TIP285
/*
*----------------------------------------------------------------------
*
* ThreadCancelObjCmd --
*
@@ -1572,11 +1489,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadCancelObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_ThreadId thrId;
@@ -1608,11 +1525,10 @@
result = NULL;
}
return ThreadCancel(interp, thrId, result, flags);
}
-#endif
/*
*----------------------------------------------------------------------
*
* ThreadSendEval --
@@ -1628,16 +1544,16 @@
*/
static int
ThreadSendEval(
Tcl_Interp *interp,
- ClientData clientData
+ void *clientData
) {
- ThreadSendData *sendPtr = (ThreadSendData*)clientData;
+ ThreadSendData *sendPtr = (ThreadSendData *)clientData;
char *script = (char*)sendPtr->clientData;
- return Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
+ return Tcl_EvalEx(interp, script, TCL_AUTO_LENGTH, TCL_EVAL_GLOBAL);
}
/*
*----------------------------------------------------------------------
*
@@ -1656,11 +1572,11 @@
*/
static int
ThreadClbkSetVar(
Tcl_Interp *interp,
- ClientData clientData
+ void *clientData
) {
ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
Tcl_Obj *var = (Tcl_Obj *)clbkPtr->clientData;
Tcl_Obj *valObj;
ThreadEventResult *resultPtr = &clbkPtr->result;
@@ -1689,16 +1605,16 @@
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);
+ Tcl_Free(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_SetVar2Ex(interp, "errorInfo", NULL,
Tcl_NewStringObj(resultPtr->errorInfo, -1), TCL_GLOBAL_ONLY);
- ckfree((char*)resultPtr->errorInfo);
+ Tcl_Free(resultPtr->errorInfo);
}
Tcl_SetObjResult(interp, valObj);
Tcl_BackgroundException(interp, TCL_ERROR);
return TCL_ERROR;
}
@@ -1707,11 +1623,11 @@
cleanup:
Tcl_DecrRefCount(valObj);
return rc;
}
-static int ThreadClbkCommand(Tcl_Interp *interp, ClientData clientData)
+static int ThreadClbkCommand(Tcl_Interp *interp, void *clientData)
{
int status = TCL_OK;
ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
Tcl_Obj *script = (Tcl_Obj *)clbkPtr->clientData;
ThreadEventResult *resultPtr = &clbkPtr->result;
@@ -1770,11 +1686,11 @@
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));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using
@@ -1797,11 +1713,11 @@
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
ThreadGetHandle(thrId, thrHandle);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, TCL_AUTO_LENGTH));
return TCL_OK;
}
/*
@@ -1833,11 +1749,11 @@
*----------------------------------------------------------------------
*/
Tcl_ThreadCreateType
NewThread(
- ClientData clientData
+ void *clientData
) {
ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Interp *interp;
int result = TCL_OK;
@@ -1879,12 +1795,12 @@
* 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);
+ evalScript = strcpy((char *)Tcl_Alloc(scriptLen+1), ctrlPtr->script);
+ Tcl_CreateThreadExitHandler(ThreadExitProc, evalScript);
/*
* Notify the parent we are alive.
*/
@@ -1979,23 +1895,23 @@
/* Fixes the [#634845] bug; credits to
* Wojciech Kocjan */
return;
}
ThreadGetHandle(Tcl_GetCurrentThread(), buf);
- Tcl_WriteChars(errChannel, "Error from thread ", -1);
- Tcl_WriteChars(errChannel, buf, -1);
+ Tcl_WriteChars(errChannel, "Error from thread ", TCL_AUTO_LENGTH);
+ Tcl_WriteChars(errChannel, buf, TCL_AUTO_LENGTH);
Tcl_WriteChars(errChannel, "\n", 1);
- Tcl_WriteChars(errChannel, errorInfo, -1);
+ Tcl_WriteChars(errChannel, errorInfo, TCL_AUTO_LENGTH);
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 = (ThreadSendData *)Tcl_Alloc(sizeof(ThreadSendData));
sendPtr->execProc = ThreadSendEval;
sendPtr->freeProc = threadSendFree;
sendPtr->clientData = Tcl_Merge(3, argv);
sendPtr->interp = NULL;
@@ -2174,11 +2090,11 @@
/*
* Allocate storage for passing thread id's to caller
*/
- *thrIdArray = (Tcl_ThreadId*)ckalloc(count * sizeof(Tcl_ThreadId));
+ *thrIdArray = (Tcl_ThreadId *)Tcl_Alloc(count * sizeof(Tcl_ThreadId));
/*
* Second walk; fill-in the array with thread ID's
*/
@@ -2252,11 +2168,10 @@
}
return NULL;
}
-#ifdef TCL_TIP285
/*
*----------------------------------------------------------------------
*
* ThreadCancel --
*
@@ -2289,26 +2204,19 @@
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);
+ resultObj = Tcl_NewStringObj(result, TCL_AUTO_LENGTH);
}
code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);
Tcl_MutexUnlock(&threadMutex);
return code;
}
-#endif
/*
*----------------------------------------------------------------------
*
* ThreadJoin --
@@ -2395,14 +2303,14 @@
TransferEvent *evPtr;
TransferResult *resultPtr;
if (!Tcl_IsChannelRegistered(interp, chan)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_AUTO_LENGTH));
}
if (Tcl_IsChannelShared(chan)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
/*
* Short circuit transfers to ourself. Nothing to do.
@@ -2432,12 +2340,12 @@
/*
* Wrap it into an event.
*/
- resultPtr = (TransferResult*)ckalloc(sizeof(TransferResult));
- evPtr = (TransferEvent *)ckalloc(sizeof(TransferEvent));
+ resultPtr = (TransferResult *)Tcl_Alloc(sizeof(TransferResult));
+ evPtr = (TransferEvent *)Tcl_Alloc(sizeof(TransferEvent));
evPtr->chan = chan;
evPtr->event.proc = TransferEventProc;
evPtr->resultPtr = resultPtr;
@@ -2505,23 +2413,23 @@
Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
Tcl_AppendResult(interp, "transfer failed: ", NULL);
if (resultPtr->resultMsg) {
Tcl_AppendResult(interp, resultPtr->resultMsg, NULL);
- ckfree(resultPtr->resultMsg);
+ Tcl_Free(resultPtr->resultMsg);
} else {
Tcl_AppendResult(interp, "for reasons unknown", NULL);
}
- ckfree((char *)resultPtr);
+ Tcl_Free(resultPtr);
return TCL_ERROR;
}
if (resultPtr->resultMsg) {
- ckfree(resultPtr->resultMsg);
+ Tcl_Free(resultPtr->resultMsg);
}
- ckfree((char *)resultPtr);
+ Tcl_Free(resultPtr);
return TCL_OK;
}
/*
@@ -2551,14 +2459,14 @@
) {
TransferEvent *evPtr;
TransferResult *resultPtr;
if (!Tcl_IsChannelRegistered(interp, chan)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is not registered here", TCL_AUTO_LENGTH));
}
if (Tcl_IsChannelShared(chan)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("channel is shared", TCL_AUTO_LENGTH));
return TCL_ERROR;
}
/*
* Cut the channel out of the interp/thread
@@ -2571,12 +2479,12 @@
* 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));
+ resultPtr = (TransferResult *)Tcl_Alloc(sizeof(TransferResult));
+ evPtr = (TransferEvent *)Tcl_Alloc(sizeof(TransferEvent));
evPtr->chan = chan;
evPtr->event.proc = NULL;
evPtr->resultPtr = resultPtr;
@@ -2654,12 +2562,12 @@
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "channel already exists", NULL);
return TCL_ERROR;
}
SpliceOut(resPtr, transferList);
- ckfree((char*)resPtr->eventPtr);
- ckfree((char*)resPtr);
+ Tcl_Free(resPtr->eventPtr);
+ Tcl_Free(resPtr);
found = 1;
break;
}
}
Tcl_MutexUnlock(&threadMutex);
@@ -2728,11 +2636,11 @@
ThreadFreeProc(send);
if (clbk) {
ThreadFreeProc(clbk);
}
if (inerror) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("thread is in error", TCL_AUTO_LENGTH));
} else {
ErrorNoSuchThread(interp, thrId);
}
return TCL_ERROR;
}
@@ -2758,11 +2666,11 @@
/*
* Create the event for target thread event queue.
*/
- eventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
+ eventPtr = (ThreadEvent *)Tcl_Alloc(sizeof(ThreadEvent));
eventPtr->sendData = send;
eventPtr->clbkData = clbk;
/*
* Target thread about to service
@@ -2783,11 +2691,11 @@
}
if ((flags & THREAD_SEND_WAIT) == 0) {
resultPtr = NULL;
eventPtr->resultPtr = NULL;
} else {
- resultPtr = (ThreadEventResult*)ckalloc(sizeof(ThreadEventResult));
+ resultPtr = (ThreadEventResult *)Tcl_Alloc(sizeof(ThreadEventResult));
resultPtr->done = NULL;
resultPtr->result = NULL;
resultPtr->errorCode = NULL;
resultPtr->errorInfo = NULL;
resultPtr->dstThreadId = thrId;
@@ -2845,15 +2753,15 @@
*/
if (resultPtr->code == TCL_ERROR) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
- ckfree(resultPtr->errorCode);
+ Tcl_Free(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
- Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
- ckfree(resultPtr->errorInfo);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_AUTO_LENGTH));
+ Tcl_Free(resultPtr->errorInfo);
}
}
code = resultPtr->code;
Tcl_SetObjResult(interp, resultPtr->result);
@@ -2862,11 +2770,11 @@
* Cleanup
*/
Tcl_ConditionFinalize(&resultPtr->done);
Tcl_DecrRefCount(resultPtr->result);
- ckfree((char*)resultPtr);
+ Tcl_Free(resultPtr);
return code;
}
/*
@@ -2919,38 +2827,29 @@
* (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
+ /*
+ * If the script has been unwound, bail out immediately. This does
+ * not follow the recommended guidelines for how extensions should
+ * handle the script cancellation functionality because this is
+ * not a "normal" extension. Most extensions do not have a command
+ * that simply enters an infinite Tcl event loop. Normal extensions
+ * should not specify the TCL_CANCEL_UNWIND when calling the
+ * Tcl_Canceled function to check if the command has been canceled.
+ */
+
+ if (Tcl_Canceled(tsdPtr->interp,
+ TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
+ code = TCL_ERROR;
+ break;
+ }
+ if (Tcl_LimitExceeded(tsdPtr->interp)) {
+ code = TCL_ERROR;
+ break;
+ }
/*
* Test stop condition under mutex since
* some other thread may flip our flags.
*/
@@ -2958,11 +2857,10 @@
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.
*/
@@ -2978,11 +2876,10 @@
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.
*/
@@ -3073,11 +2970,11 @@
* be absolutely sure that the thread has exited.
*/
if (dowait) {
resultPtr = (ThreadEventResult*)
- ckalloc(sizeof(ThreadEventResult));
+ Tcl_Alloc(sizeof(ThreadEventResult));
resultPtr->done = NULL;
resultPtr->result = NULL;
resultPtr->code = TCL_OK;
resultPtr->errorCode = NULL;
resultPtr->errorInfo = NULL;
@@ -3084,11 +2981,11 @@
resultPtr->dstThreadId = thrId;
resultPtr->srcThreadId = Tcl_GetCurrentThread();
SpliceIn(resultPtr, resultList);
}
- evPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
+ evPtr = (ThreadEvent *)Tcl_Alloc(sizeof(ThreadEvent));
evPtr->event.proc = ThreadEventProc;
evPtr->sendData = NULL;
evPtr->clbkData = NULL;
evPtr->resultPtr = resultPtr;
@@ -3100,11 +2997,11 @@
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
SpliceOut(resultPtr, resultList);
Tcl_ConditionFinalize(&resultPtr->done);
Tcl_DecrRefCount(resultPtr->result);
- ckfree((char*)resultPtr);
+ Tcl_Free(resultPtr);
}
}
}
Tcl_MutexUnlock(&threadMutex);
@@ -3319,17 +3216,17 @@
resultPtr->code = code;
if (errorCode != NULL) {
size = strlen(errorCode) + 1;
- resultPtr->errorCode = (char *)memcpy(ckalloc(size), errorCode, size);
+ resultPtr->errorCode = (char *)memcpy(Tcl_Alloc(size), errorCode, size);
} else {
resultPtr->errorCode = NULL;
}
if (errorInfo != NULL) {
size = strlen(errorInfo) + 1;
- resultPtr->errorInfo = (char *)memcpy(ckalloc(size), errorInfo, size);
+ resultPtr->errorInfo = (char *)memcpy(Tcl_Alloc(size), errorInfo, size);
} else {
resultPtr->errorInfo = NULL;
}
}
@@ -3550,11 +3447,11 @@
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);
+ resultPtr->resultMsg = (char *)memcpy(Tcl_Alloc(size), msg, size);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
@@ -3570,30 +3467,30 @@
*
* Results:
* None.
*
* Side effects:
- * Clears up mem specified in ClientData
+ * Clears up mem specified in clientData
*
*----------------------------------------------------------------------
*/
static void
ThreadFreeProc(
- ClientData clientData
+ void *clientData
) {
/*
* This will free send and/or callback structures
* since both are the same in the beginning.
*/
- ThreadSendData *anyPtr = (ThreadSendData*)clientData;
+ ThreadSendData *anyPtr = (ThreadSendData *)clientData;
if (anyPtr) {
if (anyPtr->clientData) {
(*anyPtr->freeProc)(anyPtr->clientData);
}
- ckfree((char*)anyPtr);
+ Tcl_Free(anyPtr);
}
}
/*
*----------------------------------------------------------------------
@@ -3612,11 +3509,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
- ClientData clientData /* dummy */
+ void *clientData /* dummy */
) {
if (eventPtr->proc == ThreadEventProc) {
/*
* Regular script event. Just dispose memory
*/
@@ -3681,22 +3578,22 @@
*
*----------------------------------------------------------------------
*/
static void
ThreadExitProc(
- ClientData clientData
+ void *clientData
) {
- char *threadEvalScript = (char*)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_Free(threadEvalScript);
}
Tcl_MutexLock(&threadMutex);
/*
@@ -3732,11 +3629,11 @@
* 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);
+ Tcl_Free(resultPtr);
} else if (resultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller.
@@ -3761,20 +3658,20 @@
* This should not happen, as this thread should be in
* ThreadTransfer at location (*).
*/
SpliceOut(tResultPtr, transferList);
- ckfree((char*)tResultPtr);
+ Tcl_Free(tResultPtr);
} else if (tResultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller.
* The result string must be dynamically allocated
* because the main thread is going to call free on it.
*/
- tResultPtr->resultMsg = strcpy((char *)ckalloc(1+strlen(diemsg)),
+ tResultPtr->resultMsg = strcpy((char *)Tcl_Alloc(1+strlen(diemsg)),
diemsg);
tResultPtr->resultCode = TCL_ERROR;
Tcl_ConditionNotify(&tResultPtr->done);
}
}
Index: generic/threadPoolCmd.c
==================================================================
--- generic/threadPoolCmd.c
+++ generic/threadPoolCmd.c
@@ -119,11 +119,11 @@
static int
CreateWorker(Tcl_Interp *interp, ThreadPool *tpoolPtr);
static Tcl_ThreadCreateType
-TpoolWorker(ClientData clientData);
+TpoolWorker(void *clientData);
static int
RunStopEvent(Tcl_Event *evPtr, int mask);
static void
@@ -152,14 +152,14 @@
static ThreadPool*
GetTpoolUnl(const char *tpoolName);
static void
-ThrExitHandler(ClientData clientData);
+ThrExitHandler(void *clientData);
static void
-AppExitHandler(ClientData clientData);
+AppExitHandler(void *clientData);
static int
TpoolReserve(ThreadPool *tpoolPtr);
static size_t
@@ -192,11 +192,11 @@
*----------------------------------------------------------------------
*/
static int
TpoolCreateObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ii, minw, maxw, idle;
@@ -237,14 +237,14 @@
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);
+ cmd = strcpy((char *)Tcl_Alloc(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);
+ exs = strcpy((char *)Tcl_Alloc(objv[ii+1]->length+1), val);
} else {
goto usage;
}
}
@@ -264,11 +264,11 @@
/*
* Allocate and initialize thread pool structure
*/
- tpoolPtr = (ThreadPool*)ckalloc(sizeof(ThreadPool));
+ tpoolPtr = (ThreadPool *)Tcl_Alloc(sizeof(ThreadPool));
memset(tpoolPtr, 0, sizeof(ThreadPool));
tpoolPtr->minWorkers = minw;
tpoolPtr->maxWorkers = maxw;
tpoolPtr->idleTime = idle;
@@ -297,11 +297,11 @@
}
}
Tcl_MutexUnlock(&tpoolPtr->mutex);
sprintf(buf, "%s%p", TPOOL_HNDLPREFIX, tpoolPtr);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_AUTO_LENGTH));
return TCL_OK;
usage:
Tcl_WrongNumArgs(interp, 1, objv,
@@ -328,11 +328,11 @@
*----------------------------------------------------------------------
*/
static int
TpoolPostObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
Tcl_WideInt jobId = 0;
@@ -454,19 +454,19 @@
/*
* Create new job ticket and put it on the list.
*/
- rPtr = (TpoolResult*)ckalloc(sizeof(TpoolResult));
+ rPtr = (TpoolResult *)Tcl_Alloc(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->script = strcpy((char *)Tcl_Alloc(len+1), script);
rPtr->scriptLen = len;
rPtr->detached = detached;
rPtr->threadId = Tcl_GetCurrentThread();
PushWork(rPtr, tpoolPtr);
@@ -500,16 +500,17 @@
*
*----------------------------------------------------------------------
*/
static int
TpoolWaitObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
- int ii, done, wObjc;
+ int ii, done;
+ int wObjc;
Tcl_WideInt jobId;
char *tpoolName;
Tcl_Obj *listVar = NULL;
Tcl_Obj *waitList, *doneList, **wObjv;
ThreadPool *tpoolPtr;
@@ -615,16 +616,17 @@
*
*----------------------------------------------------------------------
*/
static int
TpoolCancelObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
- int ii, wObjc;
+ int ii;
+ int wObjc;
Tcl_WideInt jobId;
char *tpoolName;
Tcl_Obj *listVar = NULL;
Tcl_Obj *doneList, *waitList, **wObjv;
ThreadPool *tpoolPtr;
@@ -672,12 +674,12 @@
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_Free(rPtr->script);
+ Tcl_Free(rPtr);
Tcl_ListObjAppendElement(interp, doneList, wObjv[ii]);
break;
}
}
if (rPtr == NULL && listVar) {
@@ -711,11 +713,11 @@
*
*----------------------------------------------------------------------
*/
static int
TpoolGetObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ret;
@@ -776,11 +778,11 @@
Tcl_DeleteHashEntry(hPtr);
Tcl_MutexUnlock(&tpoolPtr->mutex);
ret = rPtr->retcode;
SetResult(interp, rPtr);
- ckfree((char*)rPtr);
+ Tcl_Free(rPtr);
if (resVar) {
Tcl_ObjSetVar2(interp, resVar, NULL, Tcl_GetObjResult(interp), 0);
Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
ret = TCL_OK;
@@ -806,11 +808,11 @@
*----------------------------------------------------------------------
*/
static int
TpoolReserveObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ret;
@@ -861,11 +863,11 @@
*----------------------------------------------------------------------
*/
static int
TpoolReleaseObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
size_t ret;
@@ -916,11 +918,11 @@
*----------------------------------------------------------------------
*/
static int
TpoolSuspendObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char *tpoolName;
@@ -966,11 +968,11 @@
*----------------------------------------------------------------------
*/
static int
TpoolResumeObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
char *tpoolName;
@@ -1016,11 +1018,11 @@
*----------------------------------------------------------------------
*/
static int
TpoolNamesObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
ThreadPool *tpoolPtr;
@@ -1028,11 +1030,11 @@
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_ListObjAppendElement(interp, listObj, Tcl_NewStringObj(buf, TCL_AUTO_LENGTH));
}
Tcl_MutexUnlock(&listMutex);
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
@@ -1078,11 +1080,11 @@
*/
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_SetObjResult(interp, Tcl_NewStringObj("can't create a new thread", TCL_AUTO_LENGTH));
Tcl_MutexUnlock(&startMutex);
return TCL_ERROR;
}
while(result.retcode == -1) {
Tcl_ConditionWait(&tpoolPtr->cond, &startMutex, NULL);
@@ -1119,13 +1121,13 @@
*----------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
TpoolWorker(
- ClientData clientData
+ void *clientData
) {
- TpoolResult *rPtr = (TpoolResult*)clientData;
+ TpoolResult *rPtr = (TpoolResult *)clientData;
ThreadPool *tpoolPtr = rPtr->tpoolPtr;
int tout = 0;
Tcl_Interp *interp;
Tcl_Time waitTime, *idlePtr;
@@ -1151,11 +1153,11 @@
}
#endif
if (rPtr->retcode == 1) {
errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
- rPtr->result = strcpy((char *)ckalloc(strlen(errMsg)+1), errMsg);
+ rPtr->result = strcpy((char *)Tcl_Alloc(strlen(errMsg)+1), errMsg);
Tcl_ConditionNotify(&tpoolPtr->cond);
Tcl_MutexUnlock(&startMutex);
goto out;
}
@@ -1162,15 +1164,15 @@
/*
* Initialize the interpreter
*/
if (tpoolPtr->initScript) {
- TpoolEval(interp, tpoolPtr->initScript, -1, rPtr);
+ TpoolEval(interp, tpoolPtr->initScript, TCL_AUTO_LENGTH, rPtr);
if (rPtr->retcode != TCL_OK) {
rPtr->retcode = 1;
errMsg = Tcl_GetString(Tcl_GetObjResult(interp));
- rPtr->result = strcpy((char *)ckalloc(strlen(errMsg)+1), errMsg);
+ rPtr->result = strcpy((char *)Tcl_Alloc(strlen(errMsg)+1), errMsg);
Tcl_ConditionNotify(&tpoolPtr->cond);
Tcl_MutexUnlock(&startMutex);
goto out;
}
}
@@ -1234,29 +1236,29 @@
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_Free(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);
+ Tcl_Free(rPtr);
}
}
/*
* Tear down the worker
*/
if (tpoolPtr->exitScript) {
- TpoolEval(interp, tpoolPtr->exitScript, -1, NULL);
+ TpoolEval(interp, tpoolPtr->exitScript, TCL_AUTO_LENGTH, NULL);
}
tpoolPtr->numWorkers--;
SignalWaiter(tpoolPtr);
Tcl_MutexUnlock(&tpoolPtr->mutex);
@@ -1523,15 +1525,15 @@
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));
+ rPtr->errorCode = (char *)Tcl_Alloc(1 + strlen(errorCode));
strcpy(rPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
- rPtr->errorInfo = (char *)ckalloc(1 + strlen(errorInfo));
+ rPtr->errorInfo = (char *)Tcl_Alloc(1 + strlen(errorInfo));
strcpy(rPtr->errorInfo, errorInfo);
}
}
result = Tcl_GetString(Tcl_GetObjResult(interp));
@@ -1538,11 +1540,11 @@
reslen = Tcl_GetObjResult(interp)->length;
if (reslen == 0) {
rPtr->result = threadEmptyResult;
} else {
- rPtr->result = strcpy((char *)ckalloc(1 + reslen), result);
+ rPtr->result = strcpy((char *)Tcl_Alloc(1 + reslen), result);
}
return ret;
}
@@ -1567,20 +1569,20 @@
TpoolResult *rPtr
) {
if (rPtr->retcode == TCL_ERROR) {
if (rPtr->errorCode) {
if (interp) {
- Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode,-1));
+ Tcl_SetObjErrorCode(interp,Tcl_NewStringObj(rPtr->errorCode, TCL_AUTO_LENGTH));
}
- ckfree(rPtr->errorCode);
+ Tcl_Free(rPtr->errorCode);
rPtr->errorCode = NULL;
}
if (rPtr->errorInfo) {
if (interp) {
- Tcl_AddErrorInfo(interp, rPtr->errorInfo);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(rPtr->errorInfo, TCL_AUTO_LENGTH));
}
- ckfree(rPtr->errorInfo);
+ Tcl_Free(rPtr->errorInfo);
rPtr->errorInfo = NULL;
}
}
if (rPtr->result) {
if (rPtr->result == threadEmptyResult) {
@@ -1587,13 +1589,13 @@
if (interp) {
Tcl_ResetResult(interp);
}
} else {
if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result,-1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(rPtr->result, TCL_AUTO_LENGTH));
}
- ckfree(rPtr->result);
+ Tcl_Free(rPtr->result);
rPtr->result = NULL;
}
}
}
@@ -1677,14 +1679,14 @@
/*
* Tear down the pool structure
*/
if (tpoolPtr->initScript) {
- ckfree(tpoolPtr->initScript);
+ Tcl_Free(tpoolPtr->initScript);
}
if (tpoolPtr->exitScript) {
- ckfree(tpoolPtr->exitScript);
+ Tcl_Free(tpoolPtr->exitScript);
}
/*
* Cleanup completed but not collected jobs
*/
@@ -1691,21 +1693,21 @@
hPtr = Tcl_FirstHashEntry(&tpoolPtr->jobsDone, &search);
while (hPtr != NULL) {
rPtr = (TpoolResult*)Tcl_GetHashValue(hPtr);
if (rPtr->result && rPtr->result != threadEmptyResult) {
- ckfree(rPtr->result);
+ Tcl_Free(rPtr->result);
}
if (rPtr->retcode == TCL_ERROR) {
if (rPtr->errorInfo) {
- ckfree(rPtr->errorInfo);
+ Tcl_Free(rPtr->errorInfo);
}
if (rPtr->errorCode) {
- ckfree(rPtr->errorCode);
+ Tcl_Free(rPtr->errorCode);
}
}
- ckfree((char*)rPtr);
+ Tcl_Free(rPtr);
Tcl_DeleteHashEntry(hPtr);
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&tpoolPtr->jobsDone);
@@ -1712,16 +1714,16 @@
/*
* Cleanup jobs posted but never completed.
*/
for (rPtr = tpoolPtr->workHead; rPtr; rPtr = rPtr->nextPtr) {
- ckfree(rPtr->script);
- ckfree((char*)rPtr);
+ Tcl_Free(rPtr->script);
+ Tcl_Free(rPtr);
}
Tcl_MutexFinalize(&tpoolPtr->mutex);
Tcl_ConditionFinalize(&tpoolPtr->cond);
- ckfree((char*)tpoolPtr);
+ Tcl_Free(tpoolPtr);
return 0;
}
/*
@@ -1801,11 +1803,11 @@
waitPtr = PopWaiter(tpoolPtr);
if (waitPtr == NULL) {
return;
}
- evPtr = (Tcl_Event*)ckalloc(sizeof(Tcl_Event));
+ evPtr = (Tcl_Event *)Tcl_Alloc(sizeof(Tcl_Event));
evPtr->proc = RunStopEvent;
Tcl_ThreadQueueEvent(waitPtr->threadId,(Tcl_Event*)evPtr,TCL_QUEUE_TAIL);
Tcl_ThreadAlert(waitPtr->threadId);
}
@@ -1829,11 +1831,11 @@
InitWaiter ()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->waitPtr == NULL) {
- tsdPtr->waitPtr = (TpoolWaiter*)ckalloc(sizeof(TpoolWaiter));
+ tsdPtr->waitPtr = (TpoolWaiter *)Tcl_Alloc(sizeof(TpoolWaiter));
tsdPtr->waitPtr->prevPtr = NULL;
tsdPtr->waitPtr->nextPtr = NULL;
tsdPtr->waitPtr->threadId = Tcl_GetCurrentThread();
Tcl_CreateThreadExitHandler(ThrExitHandler, tsdPtr);
}
@@ -1854,15 +1856,15 @@
*
*----------------------------------------------------------------------
*/
static void
ThrExitHandler(
- ClientData clientData
+ void *clientData
) {
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
- ckfree((char*)tsdPtr->waitPtr);
+ Tcl_Free(tsdPtr->waitPtr);
}
/*
*----------------------------------------------------------------------
*
@@ -1878,11 +1880,11 @@
*
*----------------------------------------------------------------------
*/
static void
AppExitHandler(
- ClientData clientData
+ void *clientData
) {
ThreadPool *tpoolPtr;
Tcl_MutexLock(&listMutex);
/*
@@ -1929,11 +1931,11 @@
TCL_CMD(interp, TPOOL_CMD_PREFIX"resume", TpoolResumeObjCmd);
if (initialized == 0) {
Tcl_MutexLock(&listMutex);
if (initialized == 0) {
- Tcl_CreateExitHandler(AppExitHandler, (ClientData)-1);
+ Tcl_CreateExitHandler(AppExitHandler, (void *)-1);
initialized = 1;
}
Tcl_MutexUnlock(&listMutex);
}
return TCL_OK;
Index: generic/threadSpCmd.c
==================================================================
--- generic/threadSpCmd.c
+++ generic/threadSpCmd.c
@@ -175,11 +175,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadMutexObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int opt, ret;
@@ -186,11 +186,11 @@
size_t nameLen;
const char *mutexName;
char type;
SpMutex *mutexPtr;
- static const char *cmdOpts[] = {
+ static const char *const cmdOpts[] = {
"create", "destroy", "lock", "unlock", NULL
};
enum options {
m_CREATE, m_DESTROY, m_LOCK, m_UNLOCK
};
@@ -242,11 +242,11 @@
/*
* Create the requested mutex
*/
- mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex));
+ mutexPtr = (SpMutex *)Tcl_Alloc(sizeof(SpMutex));
mutexPtr->type = type;
mutexPtr->bucket = NULL;
mutexPtr->hentry = NULL;
mutexPtr->lock = NULL; /* Will be auto-initialized */
@@ -351,11 +351,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadRWMutexObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int opt, ret;
@@ -363,11 +363,11 @@
const char *mutexName;
SpMutex *mutexPtr;
Sp_ReadWriteMutex *rwPtr;
Sp_AnyMutex **lockPtr;
- static const char *cmdOpts[] = {
+ static const char *const cmdOpts[] = {
"create", "destroy", "rlock", "wlock", "unlock", NULL
};
enum options {
w_CREATE, w_DESTROY, w_RLOCK, w_WLOCK, w_UNLOCK
};
@@ -399,11 +399,11 @@
Tcl_Obj *nameObj;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "create");
return TCL_ERROR;
}
- mutexPtr = (SpMutex*)ckalloc(sizeof(SpMutex));
+ mutexPtr = (SpMutex *)Tcl_Alloc(sizeof(SpMutex));
mutexPtr->type = WMUTEXID;
mutexPtr->refcnt = 0;
mutexPtr->bucket = NULL;
mutexPtr->hentry = NULL;
mutexPtr->lock = NULL; /* Will be auto-initialized */
@@ -515,11 +515,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadCondObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int opt, ret, timeMsec = 0;
@@ -526,11 +526,11 @@
size_t nameLen;
const char *condvName, *mutexName;
SpMutex *mutexPtr;
SpCondv *condvPtr;
- static const char *cmdOpts[] = {
+ static const char *const cmdOpts[] = {
"create", "destroy", "notify", "wait", NULL
};
enum options {
c_CREATE, c_DESTROY, c_NOTIFY, c_WAIT
};
@@ -561,11 +561,11 @@
Tcl_Obj *nameObj;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "create");
return TCL_ERROR;
}
- condvPtr = (SpCondv*)ckalloc(sizeof(SpCondv));
+ condvPtr = (SpCondv *)Tcl_Alloc(sizeof(SpCondv));
condvPtr->refcnt = 0;
condvPtr->bucket = NULL;
condvPtr->hentry = NULL;
condvPtr->mutex = NULL;
condvPtr->cond = NULL; /* Will be auto-initialized */
@@ -683,11 +683,11 @@
*----------------------------------------------------------------------
*/
static int
ThreadEvalObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[] /* Argument objects. */
) {
int ret, optx, internal;
@@ -770,11 +770,11 @@
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);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_AUTO_LENGTH));
}
/*
* Unlock the mutex.
*/
@@ -1013,11 +1013,11 @@
PutMutex(mutexPtr);
return 0;
}
PutMutex(mutexPtr);
RemoveAnyItem(SP_MUTEX, name, len);
- ckfree((char*)mutexPtr);
+ Tcl_Free(mutexPtr);
return 1;
}
/*
@@ -1049,11 +1049,11 @@
PutCondv(condvPtr);
return 0;
}
PutCondv(condvPtr);
RemoveAnyItem(SP_CONDV, name, len);
- ckfree((char*)condvPtr);
+ Tcl_Free(condvPtr);
return 1;
}
/*
@@ -1358,15 +1358,14 @@
/*
* Allocate the mutex structure on first access
*/
- if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
+ if (*muxPtr == NULL) {
Tcl_MutexLock(&initMutex);
- if (*muxPtr == (Sp_ExclusiveMutex_*)0) {
- *muxPtr = (Sp_ExclusiveMutex_*)
- ckalloc(sizeof(Sp_ExclusiveMutex_));
+ if (*muxPtr == NULL) {
+ *muxPtr = (Sp_ExclusiveMutex_ *)Tcl_Alloc(sizeof(Sp_ExclusiveMutex_));
memset(*muxPtr, 0, sizeof(Sp_ExclusiveMutex_));
}
Tcl_MutexUnlock(&initMutex);
}
@@ -1494,11 +1493,11 @@
Tcl_MutexFinalize(&emPtr->lock);
}
if (emPtr->mutex) {
Tcl_MutexFinalize(&emPtr->mutex);
}
- ckfree((char*)*muxPtr);
+ Tcl_Free(*muxPtr);
}
}
/*
*----------------------------------------------------------------------
@@ -1527,12 +1526,12 @@
*/
if (*muxPtr == (Sp_RecursiveMutex_*)0) {
Tcl_MutexLock(&initMutex);
if (*muxPtr == (Sp_RecursiveMutex_*)0) {
- *muxPtr = (Sp_RecursiveMutex_*)
- ckalloc(sizeof(Sp_RecursiveMutex_));
+ *muxPtr = (Sp_RecursiveMutex_ *)
+ Tcl_Alloc(sizeof(Sp_RecursiveMutex_));
memset(*muxPtr, 0, sizeof(Sp_RecursiveMutex_));
}
Tcl_MutexUnlock(&initMutex);
}
@@ -1665,11 +1664,11 @@
Tcl_MutexFinalize(&rmPtr->lock);
}
if (rmPtr->cond) {
Tcl_ConditionFinalize(&rmPtr->cond);
}
- ckfree((char*)*muxPtr);
+ Tcl_Free(*muxPtr);
}
}
/*
*----------------------------------------------------------------------
@@ -1699,12 +1698,12 @@
*/
if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
Tcl_MutexLock(&initMutex);
if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
- *muxPtr = (Sp_ReadWriteMutex_*)
- ckalloc(sizeof(Sp_ReadWriteMutex_));
+ *muxPtr = (Sp_ReadWriteMutex_ *)
+ Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
}
Tcl_MutexUnlock(&initMutex);
}
@@ -1754,12 +1753,12 @@
*/
if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
Tcl_MutexLock(&initMutex);
if (*muxPtr == (Sp_ReadWriteMutex_*)0) {
- *muxPtr = (Sp_ReadWriteMutex_*)
- ckalloc(sizeof(Sp_ReadWriteMutex_));
+ *muxPtr = (Sp_ReadWriteMutex_ *)
+ Tcl_Alloc(sizeof(Sp_ReadWriteMutex_));
memset(*muxPtr, 0, sizeof(Sp_ReadWriteMutex_));
}
Tcl_MutexUnlock(&initMutex);
}
@@ -1878,11 +1877,11 @@
Tcl_ConditionFinalize(&rwPtr->rcond);
}
if (rwPtr->wcond) {
Tcl_ConditionFinalize(&rwPtr->wcond);
}
- ckfree((char*)*muxPtr);
+ Tcl_Free(*muxPtr);
}
}
/*
*----------------------------------------------------------------------
Index: generic/threadSvCmd.c
==================================================================
--- generic/threadSvCmd.c
+++ generic/threadSvCmd.c
@@ -122,16 +122,16 @@
static void SvAllocateContainers(Bucket*);
static void SvRegisterStdCommands(void);
#ifdef SV_FINALIZE
static void SvFinalizeContainers(Bucket*);
-static void SvFinalize(ClientData);
+static void SvFinalize(void *);
#endif /* SV_FINALIZE */
static PsStore* GetPsStore(const char *handle);
-static int SvObjDispatchObjCmd(ClientData arg,
+static int SvObjDispatchObjCmd(void *arg,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
/*
*-----------------------------------------------------------------------------
*
@@ -155,11 +155,11 @@
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);
+ SvCmdInfo *newCmd = (SvCmdInfo *)Tcl_Alloc(sizeof(SvCmdInfo) + len + len2);
/*
* Setup new command structure
*/
@@ -222,11 +222,11 @@
void
Sv_RegisterObjType(
const Tcl_ObjType *typePtr, /* Type of object to register */
Tcl_DupInternalRepProc *dupProc) /* Custom object duplicator */
{
- RegType *newType = (RegType*)ckalloc(sizeof(RegType));
+ RegType *newType = (RegType *)Tcl_Alloc(sizeof(RegType));
/*
* Setup new type structure
*/
@@ -261,11 +261,11 @@
void
Sv_RegisterPsStore(const PsStore *psStorePtr)
{
- PsStore *psPtr = (PsStore*)ckalloc(sizeof(PsStore));
+ PsStore *psPtr = (PsStore *)Tcl_Alloc(sizeof(PsStore));
*psPtr = *psStorePtr;
/*
* Plug-in in shared list
@@ -348,11 +348,11 @@
} 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));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("key has been deleted", TCL_AUTO_LENGTH));
return TCL_BREAK;
}
*offset = 2; /* Consumed two arguments: object, cmd */
}
@@ -402,11 +402,11 @@
* 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().
+ * function using Tcl_Free().
*
*-----------------------------------------------------------------------------
*/
static PsStore*
@@ -469,11 +469,11 @@
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 = (PsStore *)Tcl_Alloc(sizeof(PsStore));
*psPtr = *tmpPtr;
psPtr->nextPtr = NULL;
}
break;
}
@@ -573,11 +573,11 @@
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));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
return TCL_ERROR;
}
}
return TCL_OK;
}
@@ -806,11 +806,11 @@
hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &isNew);
if (!isNew) {
return (Array*)Tcl_GetHashValue(hPtr);
}
- arrayPtr = (Array*)ckalloc(sizeof(Array));
+ arrayPtr = (Array *)Tcl_Alloc(sizeof(Array));
arrayPtr->bucketPtr = bucketPtr;
arrayPtr->entryPtr = hPtr;
arrayPtr->psPtr = NULL;
arrayPtr->bindAddr = NULL;
@@ -839,11 +839,11 @@
static int
UnbindArray(Tcl_Interp *interp, Array *arrayPtr)
{
PsStore *psPtr = arrayPtr->psPtr;
if (arrayPtr->bindAddr) {
- ckfree(arrayPtr->bindAddr);
+ Tcl_Free(arrayPtr->bindAddr);
arrayPtr->bindAddr = NULL;
}
if (psPtr) {
if (psPtr->psClose(psPtr->psHandle) == -1) {
if (interp) {
@@ -850,11 +850,11 @@
const char *err = psPtr->psError(psPtr->psHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
}
return TCL_ERROR;
}
- ckfree((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
+ Tcl_Free(arrayPtr->psPtr), arrayPtr->psPtr = NULL;
arrayPtr->psPtr = NULL;
}
return TCL_OK;
}
@@ -872,11 +872,11 @@
if (arrayPtr->entryPtr) {
Tcl_DeleteHashEntry(arrayPtr->entryPtr);
}
Tcl_DeleteHashTable(&arrayPtr->vars);
- ckfree((char*)arrayPtr);
+ Tcl_Free(arrayPtr);
return TCL_OK;
}
/*
@@ -904,11 +904,11 @@
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
char *basePtr;
Container *prevPtr = NULL, *objPtr = NULL;
int i;
- basePtr = (char*)ckalloc(bytesToAlloc);
+ basePtr = (char *)Tcl_Alloc(bytesToAlloc);
memset(basePtr, 0, bytesToAlloc);
objPtr = (Container*)basePtr;
objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */
@@ -943,11 +943,11 @@
Container *tmpPtr, *objPtr = bucketPtr->freeCt;
while (objPtr) {
if (objPtr->chunkAddr == (char*)objPtr) {
tmpPtr = objPtr->nextPtr;
- ckfree((char*)objPtr);
+ Tcl_Free(objPtr);
objPtr = tmpPtr;
} else {
objPtr = objPtr->nextPtr;
}
}
@@ -1055,11 +1055,11 @@
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);
+ dupPtr->bytes = (char *)Tcl_Alloc(objPtr->length + 1);
if (objPtr->length > 0) {
memcpy((void*)dupPtr->bytes,(void*)objPtr->bytes,
(unsigned)objPtr->length);
}
dupPtr->length = objPtr->length;
@@ -1086,11 +1086,11 @@
*-----------------------------------------------------------------------------
*/
static int
SvObjDispatchObjCmd(
- ClientData arg, /* Pointer to object container. */
+ void *arg, /* Pointer to object container. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName;
@@ -1136,13 +1136,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvObjObjCmd(
- ClientData arg, /* != NULL if aolSpecial */
+ void *arg, /* != NULL if aolSpecial */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int isNew, off, ret, flg;
char buf[128];
Tcl_Obj *val = NULL;
@@ -1183,11 +1183,11 @@
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));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, TCL_AUTO_LENGTH));
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
}
/*
@@ -1207,22 +1207,23 @@
*-----------------------------------------------------------------------------
*/
static int
SvArrayObjCmd(
- ClientData arg, /* Pointer to object container. */
+ void *arg, /* Pointer to object container. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i, argx = 0, lobjc = 0, index, ret = TCL_OK;
+ int i, argx = 0, index, ret = TCL_OK;
+ int lobjc = 0;
const char *arrayName = NULL;
Array *arrayPtr = NULL;
Tcl_Obj **lobjv = NULL;
Container *svObj, *elObj = NULL;
- static const char *opts[] = {
+ static const char *const opts[] = {
"set", "reset", "get", "names", "size", "exists", "isbound",
"bind", "unbind", NULL
};
enum options {
ASET, ARESET, AGET, ANAMES, ASIZE, AEXISTS, AISBOUND,
@@ -1289,11 +1290,11 @@
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));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
}
goto cmdExit;
}
}
for (i = 0; i < lobjc; i += 2) {
@@ -1316,11 +1317,11 @@
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));
+ Tcl_NewStringObj(key, TCL_AUTO_LENGTH));
if (index == AGET) {
elObj = (Container*)Tcl_GetHashValue(hPtr);
Tcl_ListObjAppendElement(interp, resObj,
Sv_DuplicateObj(elObj->tclObj));
}
@@ -1374,11 +1375,11 @@
}
if (arrayPtr) {
Tcl_HashSearch search;
hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
arrayPtr->psPtr = psPtr;
- arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl);
+ arrayPtr->bindAddr = strcpy((char *)Tcl_Alloc(len+1), psurl);
while (hPtr) {
svObj = (Container *)Tcl_GetHashValue(hPtr);
if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) {
ret = TCL_ERROR;
goto cmdExit;
@@ -1386,11 +1387,11 @@
hPtr = Tcl_NextHashEntry(&search);
}
} else {
arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
arrayPtr->psPtr = psPtr;
- arrayPtr->bindAddr = strcpy((char *)ckalloc(len+1), psurl);
+ arrayPtr->bindAddr = strcpy((char *)Tcl_Alloc(len+1), psurl);
}
if (!psPtr->psFirst(psPtr->psHandle, &key, &val, &len)) {
do {
Tcl_Obj * tclObj = Tcl_NewStringObj(val, len);
hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &isNew);
@@ -1436,13 +1437,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvUnsetObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ii;
const char *arrayName;
Array *arrayPtr;
@@ -1502,13 +1503,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvNamesObjCmd(
- ClientData arg, /* != NULL if aolSpecial */
+ void *arg, /* != NULL if aolSpecial */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i;
const char *pattern = NULL;
Tcl_HashEntry *hPtr;
@@ -1563,13 +1564,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvGetObjCmd(
- ClientData arg, /* Pointer to object container. */
+ void *arg, /* Pointer to object container. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int off, ret;
Tcl_Obj *res;
Container *svObj = (Container*)arg;
@@ -1628,13 +1629,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvExistsObjCmd(
- ClientData arg, /* Pointer to object container. */
+ void *arg, /* Pointer to object container. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int off, ret;
Container *svObj = (Container*)arg;
@@ -1675,13 +1676,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvSetObjCmd(
- ClientData arg, /* Pointer to object container */
+ void *arg, /* Pointer to object container */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ret, off, flg, mode;
Tcl_Obj *val;
Container *svObj = (Container*)arg;
@@ -1742,13 +1743,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvIncrObjCmd(
- ClientData arg, /* Pointer to object container */
+ void *arg, /* Pointer to object container */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ 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;
@@ -1815,13 +1816,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvAppendObjCmd(
- ClientData arg, /* Pointer to object container */
+ void *arg, /* Pointer to object container */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, off, flg, ret;
Container *svObj = (Container*)arg;
@@ -1869,13 +1870,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvPopObjCmd(
- ClientData arg, /* Pointer to object container */
+ void *arg, /* Pointer to object container */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ret, off;
Tcl_Obj *retObj;
Array *arrayPtr = NULL;
@@ -1909,11 +1910,11 @@
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));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
}
ret = TCL_ERROR;
goto cmd_exit;
}
@@ -1952,13 +1953,13 @@
*-----------------------------------------------------------------------------
*/
static int
SvMoveObjCmd(
- ClientData arg, /* Pointer to object container. */
+ void *arg, /* Pointer to object container. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ret, off, isNew;
const char *toKey;
Tcl_HashEntry *hPtr;
@@ -1986,11 +1987,11 @@
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));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(err, TCL_AUTO_LENGTH));
return TCL_ERROR;
}
}
Tcl_DeleteHashEntry(svObj->entryPtr);
}
@@ -2022,13 +2023,13 @@
*----------------------------------------------------------------------
*/
static int
SvLockObjCmd(
- ClientData dummy, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ret;
Tcl_Obj *scriptObj;
Bucket *bucketPtr;
@@ -2067,11 +2068,11 @@
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);
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(msg, TCL_AUTO_LENGTH));
}
/*
* We unlock the bucket directly, w/o going to Sv_Unlock()
* since it needs the array which may be unset by the script.
@@ -2098,11 +2099,11 @@
*
*-----------------------------------------------------------------------------
*/
static int
SvHandlersObjCmd(
- ClientData arg, /* Not used. */
+ void *arg, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
PsStore *tmpPtr = NULL;
@@ -2263,14 +2264,14 @@
* 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);
+ NULL, NULL);
#ifdef NS_AOLSERVER
Tcl_CreateObjCommand(interp, cmdPtr->cmdName2, cmdPtr->objProcPtr,
- (ClientData)(size_t)cmdPtr->aolSpecial, NULL);
+ (void *)(size_t)cmdPtr->aolSpecial, NULL);
#endif
}
/*
* Create array of buckets and initialize each bucket
@@ -2277,11 +2278,11 @@
*/
if (buckets == NULL) {
Tcl_MutexLock(&bucketsMutex);
if (buckets == NULL) {
- buckets = (Bucket *)ckalloc(sizeof(Bucket) * NUMBUCKETS);
+ buckets = (Bucket *)Tcl_Alloc(sizeof(Bucket) * NUMBUCKETS);
for (i = 0; i < NUMBUCKETS; ++i) {
bucketPtr = &buckets[i];
memset(bucketPtr, 0, sizeof(Bucket));
Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS);
@@ -2338,11 +2339,11 @@
*
*-----------------------------------------------------------------------------
*/
static void
-SvFinalize (ClientData clientData)
+SvFinalize (void *clientData)
{
int i;
SvCmdInfo *cmdPtr;
RegType *regPtr;
@@ -2385,11 +2386,11 @@
}
SvFinalizeContainers(bucketPtr);
Tcl_DeleteHashTable(&bucketPtr->handles);
Tcl_DeleteHashTable(&bucketPtr->arrays);
}
- ckfree((char *)buckets), buckets = NULL;
+ Tcl_Free(buckets), buckets = NULL;
}
buckets = NULL;
Tcl_MutexUnlock(&bucketsMutex);
}
@@ -2401,11 +2402,11 @@
if (svCmdInfo != NULL) {
cmdPtr = svCmdInfo;
while (cmdPtr) {
SvCmdInfo *tmpPtr = cmdPtr->nextPtr;
- ckfree((char*)cmdPtr);
+ Tcl_Free(cmdPtr);
cmdPtr = tmpPtr;
}
svCmdInfo = NULL;
}
@@ -2415,11 +2416,11 @@
if (regType != NULL) {
regPtr = regType;
while (regPtr) {
RegType *tmpPtr = regPtr->nextPtr;
- ckfree((char*)regPtr);
+ Tcl_Free(regPtr);
regPtr = tmpPtr;
}
regType = NULL;
}
Index: generic/threadSvCmd.h
==================================================================
--- generic/threadSvCmd.h
+++ generic/threadSvCmd.h
@@ -14,10 +14,11 @@
#include
#include
#include
+#include "tclThreadInt.h"
#include "threadSpCmd.h" /* For recursive locks */
/*
* Uncomment following line to get command-line
* compatibility with AOLserver nsv_* commands
@@ -79,30 +80,30 @@
/*
* 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);
+typedef void *(ps_open_proc)(const char*);
+
+typedef int (ps_get_proc) (void *, const char*, char**, size_t*);
+typedef int (ps_put_proc) (void *, const char*, char*, size_t);
+typedef int (ps_first_proc) (void *, char**, char**, size_t*);
+typedef int (ps_next_proc) (void *, char**, char**, size_t*);
+typedef int (ps_delete_proc)(void *, const char*);
+typedef int (ps_close_proc) (void *);
+typedef void(ps_free_proc) (void *, void*);
+
+typedef const char* (ps_geterr_proc)(void *);
/*
* This structure maintains a bunch of pointers to functions implementing
* the simple persistence layer for the shared variable arrays.
*/
typedef struct PsStore {
const char *type; /* Type identifier of the persistent storage */
- ClientData psHandle; /* Handle to the opened storage */
+ void *psHandle; /* Handle to the opened storage */
ps_open_proc *psOpen; /* Function to open the persistent key store */
ps_get_proc *psGet; /* Function to retrieve value bound to key */
ps_put_proc *psPut; /* Function to store user key and value */
ps_first_proc *psFirst; /* Function to retrieve the first key/value */
ps_next_proc *psNext; /* Function to retrieve the next key/value */
Index: generic/threadSvListCmd.c
==================================================================
--- generic/threadSvListCmd.c
+++ generic/threadSvListCmd.c
@@ -7,37 +7,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* ----------------------------------------------------------------------------
*/
+#include "tclThreadInt.h"
#include "threadSvCmd.h"
#include "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".
@@ -148,17 +124,17 @@
*-----------------------------------------------------------------------------
*/
static int
SvLpopObjCmd (
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
int ret, off, llen, iarg = 0;
- tclSizeT index = 0;
+ size_t index = 0;
Tcl_Obj *elPtr = NULL;
Container *svObj = (Container*)arg;
/*
* Syntax:
@@ -185,11 +161,11 @@
ret = Tcl_GetIntForIndex(interp, objv[iarg], llen-1, &index);
if (ret != TCL_OK) {
goto cmd_err;
}
}
- if ((index < 0) || (index >= (tclSizeT)llen)) {
+ if (index >= (size_t)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;
@@ -228,17 +204,17 @@
*-----------------------------------------------------------------------------
*/
static int
SvLpushObjCmd (
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
int off, ret, flg, llen;
- tclSizeT index = 0;
+ size_t index = 0;
Tcl_Obj *args[1];
Container *svObj = (Container*)arg;
/*
* Syntax:
@@ -262,13 +238,13 @@
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)) {
+ if (index == TCL_INDEX_NONE) {
index = 0;
- } else if (index > (tclSizeT)llen) {
+ } else if (index > (size_t)llen) {
index = llen;
}
}
args[0] = Sv_DuplicateObj(objv[off]);
@@ -301,11 +277,11 @@
*-----------------------------------------------------------------------------
*/
static int
SvLappendObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
int i, ret, flg, off;
@@ -361,19 +337,19 @@
*-----------------------------------------------------------------------------
*/
static int
SvLreplaceObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
const char *firstArg;
size_t argLen;
int ret, off, llen, ndel, nargs, i, j;
- tclSizeT first, last;
+ size_t first, last;
Tcl_Obj **args = NULL;
Container *svObj = (Container*)arg;
/*
* Syntax:
@@ -402,18 +378,18 @@
goto cmd_err;
}
firstArg = Tcl_GetString(objv[off]);
argLen = objv[off]->length;
- if ((first == TCL_INDEX_NONE) || (first < 0)) {
+ if (first == TCL_INDEX_NONE) {
first = 0;
}
- if (llen && first >= (tclSizeT)llen && strncmp(firstArg, "end", argLen)) {
+ if (llen && first >= (size_t)llen && strncmp(firstArg, "end", argLen)) {
Tcl_AppendResult(interp, "list doesn't have element ", firstArg, NULL);
goto cmd_err;
}
- if (last + 1 >= (tclSizeT)llen + 1) {
+ if (last + 1 >= (size_t)llen + 1) {
last = llen - 1;
}
if (first + 1 <= last + 1) {
ndel = last - first + 1;
} else {
@@ -420,11 +396,11 @@
ndel = 0;
}
nargs = objc - (off + 2);
if (nargs) {
- args = (Tcl_Obj**)ckalloc(nargs * sizeof(Tcl_Obj*));
+ args = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
for(i = off + 2, j = 0; i < objc; i++, j++) {
args[j] = Sv_DuplicateObj(objv[i]);
}
}
@@ -433,11 +409,11 @@
if (ret != TCL_OK) {
for(i = off + 2, j = 0; i < objc; i++, j++) {
Tcl_DecrRefCount(args[j]);
}
}
- ckfree((char*)args);
+ Tcl_Free(args);
}
return Sv_PutContainer(interp, svObj, SV_CHANGED);
cmd_err:
@@ -461,17 +437,17 @@
*-----------------------------------------------------------------------------
*/
static int
SvLrangeObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
int ret, off, llen, nargs, j;
- tclSizeT first, last, i;
+ size_t first, last, i;
Tcl_Obj **elPtrs, **args;
Container *svObj = (Container*)arg;
/*
* Syntax:
@@ -497,29 +473,29 @@
}
ret = Tcl_GetIntForIndex(interp, objv[off+1], llen-1, &last);
if (ret != TCL_OK) {
goto cmd_err;
}
- if ((first == TCL_INDEX_NONE) || (first < 0)) {
+ if (first == TCL_INDEX_NONE) {
first = 0;
}
- if (last + 1 >= (tclSizeT)llen + 1) {
+ if (last + 1 >= (size_t)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*));
+ args = (Tcl_Obj **)Tcl_Alloc(nargs * sizeof(Tcl_Obj *));
for (i = first, j = 0; i <= last; i++, j++) {
args[j] = Sv_DuplicateObj(elPtrs[i]);
}
Tcl_ResetResult(interp);
Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args);
- ckfree((char*)args);
+ Tcl_Free(args);
cmd_ok:
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
cmd_err:
@@ -543,17 +519,17 @@
*-----------------------------------------------------------------------------
*/
static int
SvLinsertObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
int off, ret, flg, llen, nargs, i, j;
- tclSizeT index = 0;
+ size_t index = 0;
Tcl_Obj **args;
Container *svObj = (Container*)arg;
/*
* Syntax:
@@ -576,31 +552,31 @@
}
ret = Tcl_GetIntForIndex(interp, objv[off], llen, &index);
if (ret != TCL_OK) {
goto cmd_err;
}
- if ((index == TCL_INDEX_NONE) || (index < 0)) {
+ if (index == TCL_INDEX_NONE) {
index = 0;
- } else if (index > (tclSizeT)llen) {
+ } else if (index > (size_t)llen) {
index = llen;
}
nargs = objc - (off + 1);
- args = (Tcl_Obj**)ckalloc(nargs * sizeof(Tcl_Obj*));
+ args = (Tcl_Obj **)Tcl_Alloc(nargs * sizeof(Tcl_Obj *));
for (i = off + 1, j = 0; i < objc; i++, j++) {
args[j] = Sv_DuplicateObj(objv[i]);
}
ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, nargs, args);
if (ret != TCL_OK) {
for (i = off + 1, j = 0; i < objc; i++, j++) {
Tcl_DecrRefCount(args[j]);
}
- ckfree((char*)args);
+ Tcl_Free(args);
goto cmd_err;
}
- ckfree((char*)args);
+ Tcl_Free(args);
return Sv_PutContainer(interp, svObj, SV_CHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
@@ -623,11 +599,11 @@
*-----------------------------------------------------------------------------
*/
static int
SvLlengthObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
int llen, off, ret;
@@ -672,11 +648,11 @@
*-----------------------------------------------------------------------------
*/
static int
SvLsearchObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
size_t length;
@@ -683,11 +659,11 @@
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};
+ static const char *const modes[] = {"-exact", "-glob", "-regexp", NULL};
enum {LS_EXACT, LS_GLOB, LS_REGEXP};
mode = LS_GLOB;
/*
@@ -778,18 +754,18 @@
*-----------------------------------------------------------------------------
*/
static int
SvLindexObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
Tcl_Obj **elPtrs;
int ret, off, llen;
- tclSizeT index;
+ size_t index;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::lindex array key index
@@ -810,11 +786,11 @@
}
ret = Tcl_GetIntForIndex(interp, objv[off], llen-1, &index);
if (ret != TCL_OK) {
goto cmd_err;
}
- if ((index >= 0) && index < (tclSizeT)llen) {
+ if (index < (size_t)llen) {
Tcl_SetObjResult(interp, Sv_DuplicateObj(elPtrs[index]));
}
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
@@ -839,11 +815,11 @@
*-----------------------------------------------------------------------------
*/
static int
SvLsetObjCmd(
- ClientData arg,
+ void *arg,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
Tcl_Obj *lPtr;
@@ -906,30 +882,31 @@
static void
DupListObjShared(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr /* Object with internal rep to set. */
) {
- int i, llen;
+ int i;
+ int llen;
Tcl_Obj *elObj, **newObjList;
Tcl_ListObjLength(NULL, srcPtr, &llen);
if (llen == 0) {
(*srcPtr->typePtr->dupIntRepProc)(srcPtr, copyPtr);
copyPtr->refCount = 0;
return;
}
- newObjList = (Tcl_Obj**)ckalloc(llen*sizeof(Tcl_Obj*));
+ newObjList = (Tcl_Obj **)Tcl_Alloc(llen*sizeof(Tcl_Obj *));
for (i = 0; i < llen; i++) {
Tcl_ListObjIndex(NULL, srcPtr, i, &elObj);
newObjList[i] = Sv_DuplicateObj(elObj);
}
Tcl_SetListObj(copyPtr, llen, newObjList);
- ckfree((char*)newObjList);
+ Tcl_Free(newObjList);
}
/*
*----------------------------------------------------------------------
*
@@ -952,11 +929,11 @@
int indexCount, /* Number of index args */
Tcl_Obj **indexArray,
Tcl_Obj *valuePtr /* Value arg to 'lset' */
) {
int elemCount, result, i;
- tclSizeT index;
+ size_t index;
Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;
/*
* Determine whether the index arg designates a list
* or a single index.
@@ -1017,11 +994,11 @@
/*
* Check that the index is in range.
*/
- if ((index < 0) || index >= (tclSizeT)elemCount) {
+ if (index >= (size_t)elemCount) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
result = TCL_ERROR;
break;
}
Index: lib/ttrace.tcl
==================================================================
--- lib/ttrace.tcl
+++ lib/ttrace.tcl
@@ -71,11 +71,11 @@
} else {
error "requires NaviServer/AOLserver or Tcl threading extension"
}
# Keep in sync with the Thread package
- package provide Ttrace 2.9a1
+ package provide Ttrace 3.0a1
# Package variables
variable resolvers "" ; # List of registered resolvers
variable tracers "" ; # List of registered cmd tracers
variable scripts "" ; # List of registered script makers
Index: pkgIndex.tcl.in
==================================================================
--- pkgIndex.tcl.in
+++ pkgIndex.tcl.in
@@ -1,19 +1,18 @@
# -*- 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
- }
+# Tcl 8.6 interps are only supported on 32-bit platforms.
+# Lower than that is never supported. Bye!
+if {![package vsatisfies [package provide Tcl] 9.0]
+ && ((![package vsatisfies [package provide Tcl] 8.6])
+ || ($::tcl_platform(pointerSize)!=4))} {
+ return
}
-# All Tcl 8.4+ interps can [load] Thread @PACKAGE_VERSION@
+# All Tcl 8.6+ 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
@@ -25,32 +24,11 @@
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]
+# In Tcl 8.6+ 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
Index: tcl/cmdsrv/cmdsrv.tcl
==================================================================
--- tcl/cmdsrv/cmdsrv.tcl
+++ tcl/cmdsrv/cmdsrv.tcl
@@ -25,12 +25,12 @@
#
# 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
+package require Tcl 8.5-
+package require Thread 2.5-
namespace eval cmdsrv {
variable data; # Stores global configuration options
}
Index: tcl/phttpd/phttpd.tcl
==================================================================
--- tcl/phttpd/phttpd.tcl
+++ tcl/phttpd/phttpd.tcl
@@ -30,12 +30,12 @@
#
# 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
+package require Tcl 8.5-
+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.
Index: tcl/tpool/tpool.tcl
==================================================================
--- tcl/tpool/tpool.tcl
+++ tcl/tpool/tpool.tcl
@@ -21,11 +21,12 @@
#
# 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
+package require Tcl 8.5-
+package require Thread 2.5-
set thisScript [info script]
namespace eval tpool {
variable afterevent "" ; # Idle timer event for worker threads
Index: win/pkg.vc
==================================================================
--- win/pkg.vc
+++ win/pkg.vc
@@ -1,6 +1,6 @@
# remember to change configure.ac as well when these change
# (then re-autoconf)
-PACKAGE_MAJOR = 2
-PACKAGE_MINOR = 9
-PACKAGE_VERSION = "2.9a1"
+PACKAGE_MAJOR = 3
+PACKAGE_MINOR = 0
+PACKAGE_VERSION = "3.0a1"