#include "tclInt.h"
#ifdef TCL_THREADS
typedef struct ThreadSpecificData {
Tcl_ThreadId threadId;
Tcl_Interp *interp;
int flags;
struct ThreadSpecificData *nextPtr;
struct ThreadSpecificData *prevPtr;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static struct ThreadSpecificData *threadList;
#define TP_Dying 0x001
typedef struct ThreadCtrl {
char *script;
int flags;
Tcl_Condition condWait;
} ThreadCtrl;
typedef struct ThreadEvent {
Tcl_Event event;
char *script;
struct ThreadEventResult *resultPtr;
} ThreadEvent;
typedef struct ThreadEventResult {
Tcl_Condition done;
int code;
char *result;
char *errorInfo;
char *errorCode;
Tcl_ThreadId srcThreadId;
Tcl_ThreadId dstThreadId;
struct ThreadEvent *eventPtr;
struct ThreadEventResult *nextPtr;
struct ThreadEventResult *prevPtr;
} ThreadEventResult;
static ThreadEventResult *resultList;
static Tcl_ThreadId errorThreadId;
static char *errorProcString;
TCL_DECLARE_MUTEX(threadMutex)
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp,
char *script, int joinable));
EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id,
char *script, int wait));
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData));
static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,
ClientData clientData));
static void ThreadExitProc _ANSI_ARGS_((ClientData clientData));
int
TclThread_Init(interp)
Tcl_Interp *interp;
{
Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd,
(ClientData)NULL ,NULL);
if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
int
Tcl_ThreadObjCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names",
"send", "wait", "errorproc",
(char *) NULL};
enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN,
THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions,
"option", 0, &option) != TCL_OK) {
return TCL_ERROR;
}
if (tsdPtr->interp == NULL) {
Tcl_MutexLock(&threadMutex);
tsdPtr->interp = interp;
ListUpdateInner(tsdPtr);
Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
Tcl_MutexUnlock(&threadMutex);
}
switch ((enum options)option) {
case THREAD_CREATE: {
char *script;
int joinable, len;
if (objc == 2) {
joinable = 0;
script = "testthread wait";
} else if (objc == 3) {
script = Tcl_GetString(objv[2]);
len = strlen (script);
if ((len > 1) &&
(script [0] == '-') && (script [1] == 'j') &&
(0 == strncmp (script, "-joinable", (size_t) len))) {
joinable = 1;
script = "testthread wait";
} else {
joinable = 0;
}
} else if (objc == 4) {
script = Tcl_GetString(objv[2]);
len = strlen (script);
joinable = ((len > 1) &&
(script [0] == '-') && (script [1] == 'j') &&
(0 == strncmp (script, "-joinable", (size_t) len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
return TclCreateThread(interp, script, joinable);
}
case THREAD_EXIT: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
ListRemove(NULL);
Tcl_ExitThread(0);
return TCL_OK;
}
case THREAD_ID:
if (objc == 2) {
Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
case THREAD_JOIN: {
long id;
int result, status;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "join id");
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
if (result == TCL_OK) {
Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
} else {
char buf [20];
sprintf (buf, "%ld", id);
Tcl_AppendResult (interp, "cannot join thread ", buf, NULL);
}
return result;
}
case THREAD_NAMES: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return TclThreadList(interp);
}
case THREAD_SEND: {
long id;
char *script;
int wait, arg;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
return TCL_ERROR;
}
if (objc == 5) {
if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
return TCL_ERROR;
}
wait = 0;
arg = 3;
} else {
wait = 1;
arg = 2;
}
if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
return TCL_ERROR;
}
arg++;
script = Tcl_GetString(objv[arg]);
return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
}
case THREAD_WAIT: {
while (1) {
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
}
case THREAD_ERRORPROC: {
char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
errorProcString = ckalloc(strlen(proc)+1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
return TCL_OK;
}
int
TclCreateThread(interp, script, joinable)
Tcl_Interp *interp;
char *script;
int joinable;
{
ThreadCtrl ctrl;
Tcl_ThreadId id;
ctrl.script = script;
ctrl.condWait = NULL;
ctrl.flags = 0;
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp,"can't create a new thread",0);
ckfree((void*)ctrl.script);
return TCL_ERROR;
}
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
return TCL_OK;
}
Tcl_ThreadCreateType
NewTestThread(clientData)
ClientData clientData;
{
ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
tsdPtr->interp = Tcl_CreateInterp();
result = Tcl_Init(tsdPtr->interp);
result = TclThread_Init(tsdPtr->interp);
Tcl_MutexLock(&threadMutex);
ListUpdateInner(tsdPtr);
threadEvalScript = (char *) ckalloc(strlen(ctrlPtr->script)+1);
strcpy(threadEvalScript, ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
Tcl_ConditionNotify(&ctrlPtr->condWait);
Tcl_MutexUnlock(&threadMutex);
Tcl_Preserve((ClientData) tsdPtr->interp);
result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
}
ListRemove(tsdPtr);
Tcl_Release((ClientData) tsdPtr->interp);
Tcl_DeleteInterp(tsdPtr->interp);
Tcl_ExitThread(result);
TCL_THREAD_CREATE_RETURN;
}
static void
ThreadErrorProc(interp)
Tcl_Interp *interp;
{
Tcl_Channel errChannel;
CONST char *errorInfo, *argv[3];
char *script;
char buf[TCL_DOUBLE_SPACE+1];
sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
Tcl_WriteChars(errChannel, buf, -1);
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_WriteChars(errChannel, errorInfo, -1);
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
TclThreadSend(interp, errorThreadId, script, 0);
ckfree(script);
}
}
static void
ListUpdateInner(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
}
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->nextPtr = threadList;
if (threadList) {
threadList->prevPtr = tsdPtr;
}
tsdPtr->prevPtr = NULL;
threadList = tsdPtr;
}
static void
ListRemove(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
}
Tcl_MutexLock(&threadMutex);
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
threadList = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
Tcl_MutexUnlock(&threadMutex);
}
int
TclThreadList(interp)
Tcl_Interp *interp;
{
ThreadSpecificData *tsdPtr;
Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
Tcl_MutexLock(&threadMutex);
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewLongObj((long)tsdPtr->threadId));
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
int
TclThreadSend(interp, id, script, wait)
Tcl_Interp *interp;
Tcl_ThreadId id;
char *script;
int wait;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr;
ThreadEventResult *resultPtr;
int found, code;
Tcl_ThreadId threadId = (Tcl_ThreadId) id;
Tcl_MutexLock(&threadMutex);
found = 0;
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
if (tsdPtr->threadId == threadId) {
found = 1;
break;
}
}
if (!found) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "invalid thread id", NULL);
return TCL_ERROR;
}
if (threadId == Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
return Tcl_GlobalEval(interp, script);
}
threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
threadEventPtr->script = ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
resultPtr->done = NULL;
resultPtr->code = 0;
resultPtr->result = NULL;
resultPtr->errorInfo = NULL;
resultPtr->errorCode = NULL;
resultPtr->srcThreadId = Tcl_GetCurrentThread();
resultPtr->dstThreadId = threadId;
resultPtr->eventPtr = threadEventPtr;
resultPtr->nextPtr = resultList;
if (resultList) {
resultList->prevPtr = resultPtr;
}
resultPtr->prevPtr = NULL;
resultList = resultPtr;
}
threadEventPtr->event.proc = ThreadEventProc;
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
TCL_QUEUE_TAIL);
Tcl_ThreadAlert(threadId);
if (!wait) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
Tcl_ResetResult(interp);
while (resultPtr->result == NULL) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
if (resultPtr->prevPtr) {
resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
} else {
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->eventPtr = NULL;
resultPtr->nextPtr = NULL;
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
ckfree(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
ckfree(resultPtr->errorInfo);
}
}
Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
ckfree((char *) resultPtr);
return code;
}
static int
ThreadEventProc(evPtr, mask)
Tcl_Event *evPtr;
int mask;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
CONST char *result, *errorCode, *errorInfo;
if (interp == NULL) {
code = TCL_ERROR;
result = "no target interp!";
errorCode = "THREAD";
errorInfo = "";
} else {
Tcl_Preserve((ClientData) interp);
Tcl_ResetResult(interp);
Tcl_CreateThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
code = Tcl_GlobalEval(interp, threadEventPtr->script);
Tcl_DeleteThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
result = Tcl_GetStringResult(interp);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
}
ckfree(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
resultPtr->result = ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
Tcl_Release((ClientData) interp);
}
return 1;
}
static void
ThreadFreeProc(clientData)
ClientData clientData;
{
if (clientData) {
ckfree((char *) clientData);
}
}
static int
ThreadDeleteEvent(eventPtr, clientData)
Tcl_Event *eventPtr;
ClientData clientData;
{
if (eventPtr->proc == ThreadEventProc) {
ckfree((char *) ((ThreadEvent *) eventPtr)->script);
return 1;
}
return (eventPtr->proc == NULL);
}
static void
ThreadExitProc(clientData)
ClientData clientData;
{
char *threadEvalScript = (char *) clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
Tcl_MutexLock(&threadMutex);
if (threadEvalScript) {
ckfree((char *) threadEvalScript);
threadEvalScript = NULL;
}
Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
nextPtr = resultPtr->nextPtr;
if (resultPtr->srcThreadId == self) {
if (resultPtr->prevPtr) {
resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
} else {
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
ckfree((char *)resultPtr);
} else if (resultPtr->dstThreadId == self) {
char *msg = "target thread died";
resultPtr->result = ckalloc(strlen(msg)+1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
}
}
Tcl_MutexUnlock(&threadMutex);
}
#endif