static void
ThreadErrorProc(
Tcl_Interp *interp) /* Interp that failed */
{
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 TCL_RESULT TwapiTlsInit()
{
TwapiTls *tlsP;
TWAPI_ASSERT(gTlsIndex != TLS_OUT_OF_INDEXES);
tlsP = TlsGetValue(gTlsIndex);
if (tlsP == NULL) {
tlsP = (TwapiTls *) TwapiAllocZero(sizeof(*tlsP));
if (! TlsSetValue(gTlsIndex, tlsP)) {
TwapiFree(tlsP);
return TCL_ERROR;
}
tlsP->thread = Tcl_GetCurrentThread();
/* TBD - should we raise alloc from 8000 ? Too small ? */
if (MemLifoInit(&tlsP->memlifo, NULL, NULL, NULL, 8000,
MEMLIFO_F_PANIC_ON_FAIL) != ERROR_SUCCESS) {
TwapiFree(tlsP);
return TCL_ERROR;
}
tlsP->ffiObj = ObjNewDict();
ObjIncrRefs(tlsP->ffiObj);
}
tlsP->nrefs += 1;
return TCL_OK;
}
static int newpvInfo (Tcl_Interp *interp, const char *name, Tcl_Obj *prefix) {
pvInfo *result=ckalloc(sizeof(pvInfo));
result->interp=interp;
result->name=ckstrdup(name);
if (prefix) Tcl_IncrRefCount(prefix);
result->connectprefix = prefix;
result->id = 0;
result->connected = 0;
result->thrid = Tcl_GetCurrentThread();
result->monitorid = 0;
result->monitorprefix = NULL;
result->nElem = 1;
result->type = -1;
/* connect PV */
int code = ca_create_channel(name, stateHandler, result, 0, &(result->id));
if (code != ECA_NORMAL) {
/* raise error */
freepvInfo(result);
Tcl_SetObjResult(interp, Tcl_NewStringObj(ca_message(code), -1));
return TCL_ERROR;
}
/* Create handle */
static int pvcounter = 0;
char objName[50 + TCL_INTEGER_SPACE];
sprintf(objName, "::AsynCA::PV%d", ++pvcounter);
result->cmd = Tcl_CreateObjCommand(interp, objName, InstanceCmd, (ClientData) result, DeleteCmd);
Tcl_SetObjResult(interp, Tcl_NewStringObj(objName, -1));
return TCL_OK;
}
Tcl_AsyncHandler
Tcl_AsyncCreate(
Tcl_AsyncProc *proc, /* Procedure to call when handler is
* invoked. */
ClientData clientData) /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
asyncPtr->originTsd = tsdPtr;
asyncPtr->originThrdId = Tcl_GetCurrentThread();
Tcl_MutexLock(&tsdPtr->asyncMutex);
if (tsdPtr->firstHandler == NULL) {
tsdPtr->firstHandler = asyncPtr;
} else {
tsdPtr->lastHandler->nextPtr = asyncPtr;
}
tsdPtr->lastHandler = asyncPtr;
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
return (Tcl_AsyncHandler) asyncPtr;
}
SyncPointMapEntry
AcquireSyncPoint (
int signum,
ClientData clientData,
int *isnewPtr)
{
SignalMapEntry *entryPtr;
SyncPoint *spointPtr;
entryPtr = CreateSigMapEntry(&syncpoints, signum, isnewPtr);
if (*isnewPtr) {
spointPtr = AllocSyncPoint(signum, clientData);
SetSigMapValue(entryPtr, spointPtr);
} else {
Tcl_ThreadId thisThreadId;
spointPtr = GetSigMapValue(entryPtr);
thisThreadId = Tcl_GetCurrentThread();
if (spointPtr->signaled == 0) {
spointPtr->threadId = thisThreadId;
spointPtr->clientData = clientData;
} else {
if (spointPtr->threadId != thisThreadId) {
SyncPoint *newPtr;
QueuePush(&danglingSpoints, spointPtr);
newPtr = AllocSyncPoint(signum, clientData);
SetSigMapValue(entryPtr, newPtr);
} else {
/* Do nothing -- the syncpoint is already ours */
}
}
}
return entryPtr;
}
void Panic (Tcl_Interp * pintrp, const char * pch)
{
printf("Thread %P:",Tcl_GetCurrentThread());
printf(pch);
printf("\n Reason:");
printf(pintrp->result);
printf("\n");
Tcl_DeleteInterp(pintrp);
Tcl_Exit(1);
}
/* ARGSUSED */
static void
ThreadExitProc(
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) {
/*
* We are going away. By freeing up the result we signal to the
* other thread we don't care about the result.
*/
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) {
/*
* 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.
*/
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);
}
void
TclpThreadExit(
int status)
{
EnterCriticalSection(&joinLock);
TclSignalExitThread(Tcl_GetCurrentThread(), status);
LeaveCriticalSection(&joinLock);
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
_endthreadex((unsigned) status);
#else
ExitThread((DWORD) status);
#endif
}
void *
TclpThreadDataKeyGet(
Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk, really
* (int**) */
{
Tcl_HashTable *hashTablePtr =
ThreadStorageGetHashTable(Tcl_GetCurrentThread());
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(hashTablePtr, (char *) keyPtr);
if (hPtr == NULL) {
return NULL;
}
return Tcl_GetHashValue(hPtr);
}
void
TclpThreadDataKeySet(
Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk, really
* (pthread_key_t **) */
void *data) /* Thread local storage */
{
Tcl_HashTable *hashTablePtr;
Tcl_HashEntry *hPtr;
int dummy;
hashTablePtr = ThreadStorageGetHashTable(Tcl_GetCurrentThread());
hPtr = Tcl_CreateHashEntry(hashTablePtr, (char *)keyPtr, &dummy);
Tcl_SetHashValue(hPtr, data);
}
static void
ListUpdateInner(
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 Cache *
GetCache(void)
{
Cache *cachePtr;
/*
* Check for first-time initialization.
*/
if (listLockPtr == NULL) {
Tcl_Mutex *initLockPtr;
unsigned int i;
initLockPtr = Tcl_GetAllocMutex();
Tcl_MutexLock(initLockPtr);
if (listLockPtr == NULL) {
listLockPtr = TclpNewAllocMutex();
objLockPtr = TclpNewAllocMutex();
for (i = 0; i < NBUCKETS; ++i) {
bucketInfo[i].blockSize = MINALLOC << i;
bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
bucketInfo[i].numMove = i < NBUCKETS - 1 ?
1 << (NBUCKETS - 2 - i) : 1;
bucketInfo[i].lockPtr = TclpNewAllocMutex();
}
}
Tcl_MutexUnlock(initLockPtr);
}
/*
* Get this thread's cache, allocating if necessary.
*/
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = calloc(1, sizeof(Cache));
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
Tcl_MutexLock(listLockPtr);
cachePtr->nextPtr = firstCachePtr;
firstCachePtr = cachePtr;
Tcl_MutexUnlock(listLockPtr);
cachePtr->owner = Tcl_GetCurrentThread();
TclpSetAllocCache(cachePtr);
}
return cachePtr;
}
void
DeleteSyncPoint (
SyncPointMapEntry entry)
{
SyncPoint *spointPtr;
spointPtr = GetSigMapValue(entry);
if (spointPtr->signaled != 0) {
if (spointPtr->threadId != Tcl_GetCurrentThread()) {
QueuePush(&danglingSpoints, spointPtr);
/* TODO notify the owner thread that it has just
* lost the syncpoint and should free any state
* associated with it */
}
}
DeleteSigMapEntry(entry);
}
void
Tcl_AsyncDelete(
Tcl_AsyncHandler async) /* Token for handler to delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
AsyncHandler *asyncPtr = (AsyncHandler *) async;
AsyncHandler *prevPtr, *thisPtr;
/*
* Assure early handling of the constraint
*/
if (asyncPtr->originThrdId != Tcl_GetCurrentThread()) {
Tcl_Panic("Tcl_AsyncDelete: async handler deleted by the wrong thread");
}
/*
* If we come to this point when TSD's for the current
* thread have already been garbage-collected, we are
* in the _serious_ trouble. OTOH, we tolerate calling
* with already cleaned-up handler list (should we?).
*/
Tcl_MutexLock(&tsdPtr->asyncMutex);
if (tsdPtr->firstHandler != NULL) {
prevPtr = thisPtr = tsdPtr->firstHandler;
while (thisPtr != NULL && thisPtr != asyncPtr) {
prevPtr = thisPtr;
thisPtr = thisPtr->nextPtr;
}
if (thisPtr == NULL) {
Tcl_Panic("Tcl_AsyncDelete: cannot find async handler");
}
if (asyncPtr == tsdPtr->firstHandler) {
tsdPtr->firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
if (asyncPtr == tsdPtr->lastHandler) {
tsdPtr->lastHandler = prevPtr;
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
ckfree((char *) asyncPtr);
}
static
SyncPoint*
AllocSyncPoint (
int signum,
ClientData clientData)
{
SyncPoint *spointPtr;
spointPtr = (SyncPoint*) ckalloc(sizeof(*spointPtr));
#ifdef TCL_THREADS
spointPtr->threadId = Tcl_GetCurrentThread();
#endif
spointPtr->signum = signum;
spointPtr->signaled = 0;
spointPtr->clientData = clientData;
spointPtr->nextPtr = NULL;
return spointPtr;
}
Tcl_Channel
TclWinOpenConsoleChannel(
HANDLE handle,
char *channelName,
int permissions)
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
DWORD id, modes;
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
infoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel. This keeps the
* channel names unique, since some may share handles (stdin/stdout/stderr
* for instance).
*/
wsprintfA(channelName, "file%lx", (int) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
(ClientData) infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
GetConsoleMode(infoPtr->handle, &modes);
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread,
infoPtr, 0, &id);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
}
if (permissions & TCL_WRITABLE) {
infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread,
infoPtr, 0, &id);
SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
if (tclWinProcs->useWide)
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
else
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
return infoPtr->channel;
}
void
TclpFinalizeThreadDataThread(void)
{
Tcl_ThreadId id = Tcl_GetCurrentThread();
/* Id of the thread to finalize. */
int index = PTR2UINT(id) % STORAGE_CACHE_SLOTS;
Tcl_HashEntry *hPtr; /* Hash entry for current thread in master
* table. */
Tcl_HashTable* hashTablePtr;/* Pointer to the hash table holding TSD
* blocks for the current thread*/
Tcl_HashSearch search; /* Search object to walk the TSD blocks in the
* designated thread */
Tcl_HashEntry *hPtr2; /* Hash entry for a TSD block in the
* designated thread. */
Tcl_MutexLock(&threadStorageLock);
hPtr = Tcl_FindHashEntry(&threadStorageHashTable, (char*)id);
if (hPtr == NULL) {
hashTablePtr = NULL;
} else {
/*
* We found it, extract the hash table pointer.
*/
hashTablePtr = Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
/*
* Make sure cache entry for this thread is NULL.
*/
if (threadStorageCache[index].id == id) {
/*
* We do not step on another thread's cache entry. This is
* especially important if we are creating and exiting a lot of
* threads.
*/
threadStorageCache[index].id = STORAGE_INVALID_THREAD;
threadStorageCache[index].hashTablePtr = NULL;
}
}
Tcl_MutexUnlock(&threadStorageLock);
/*
* The thread's hash table has been extracted and removed from the master
* hash table. Now clean up the thread.
*/
if (hashTablePtr != NULL) {
/*
* Free all TSD
*/
for (hPtr2 = Tcl_FirstHashEntry(hashTablePtr, &search); hPtr2 != NULL;
hPtr2 = Tcl_NextHashEntry(&search)) {
void *blockPtr = Tcl_GetHashValue(hPtr2);
if (blockPtr != NULL) {
/*
* The block itself was allocated in Tcl_GetThreadData using
* ckalloc; use ckfree to dispose of it.
*/
ckfree(blockPtr);
}
}
/*
* Delete thread specific hash table and free the struct.
*/
Tcl_DeleteHashTable(hashTablePtr);
TclpSysFree((char *) hashTablePtr);
}
}
const int nStack = TCL_THREAD_STACK_DEFAULT;
const int flags = TCL_THREAD_NOFLAGS;
assert(objc==4);
UNUSED_PARAMETER(clientData);
UNUSED_PARAMETER(objc);
zVarname = Tcl_GetStringFromObj(objv[2], &nVarname);
zScript = Tcl_GetStringFromObj(objv[3], &nScript);
pNew = (SqlThread *)ckalloc(sizeof(SqlThread)+nVarname+nScript+2);
pNew->zVarname = (char *)&pNew[1];
pNew->zScript = (char *)&pNew->zVarname[nVarname+1];
memcpy(pNew->zVarname, zVarname, nVarname+1);
memcpy(pNew->zScript, zScript, nScript+1);
pNew->parent = Tcl_GetCurrentThread();
pNew->interp = interp;
rc = Tcl_CreateThread(&x, tclScriptThread, (void *)pNew, nStack, flags);
if( rc!=TCL_OK ){
Tcl_AppendResult(interp, "Error in Tcl_CreateThread()", 0);
ckfree((char *)pNew);
return TCL_ERROR;
}
return TCL_OK;
}
/*
** sqlthread parent SCRIPT
**
Tcl_Channel
TclWinOpenConsoleChannel(
HANDLE handle,
char *channelName,
int permissions)
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
DWORD modes;
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = ckalloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
infoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel. This keeps the
* channel names unique, since some may share handles (stdin/stdout/stderr
* for instance).
*/
sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
GetConsoleMode(infoPtr->handle, &modes);
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
StartChannelThread(infoPtr, &infoPtr->reader, ConsoleReaderThread);
}
if (permissions & TCL_WRITABLE) {
StartChannelThread(infoPtr, &infoPtr->writer, ConsoleWriterThread);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
#ifdef UNICODE
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
#else
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
#endif
return infoPtr->channel;
}
/* ARGSUSED */
int
Tcl_ThreadObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
static const char *threadOptions[] = {
"create", "exit", "id", "join", "names",
"send", "wait", "errorproc", 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;
}
/*
* Make sure the initial thread is on the list before doing anything.
*/
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) {
/*
* Neither joinable nor special script
*/
joinable = 0;
script = "testthread wait"; /* Just enter event loop */
} else if (objc == 3) {
/*
* Possibly -joinable, then no special script, no joinable, then
* its a script.
*/
script = Tcl_GetStringFromObj(objv[2], &len);
if ((len > 1) &&
(script [0] == '-') && (script [1] == 'j') &&
(0 == strncmp (script, "-joinable", (size_t) len))) {
joinable = 1;
script = "testthread wait"; /* Just enter event loop */
} else {
/*
* Remember the script
*/
joinable = 0;
}
} else if (objc == 4) {
/*
* Definitely a script available, but is the flag -joinable?
*/
script = Tcl_GetStringFromObj(objv[2], &len);
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, 2, 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, 2, objv, "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, 2, objv, "?-async? id script");
return TCL_ERROR;
}
if (objc == 5) {
if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
Tcl_WrongNumArgs(interp, 2, objv, "?-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_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
*/
char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "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;
}
case THREAD_WAIT:
while (1) {
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
}
return TCL_OK;
}
int
TclThreadSend(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_ThreadId id, /* Thread Id of other interpreter. */
char *script, /* The script to evaluate. */
int wait) /* If 1, we block for the result. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr;
ThreadEventResult *resultPtr;
int found, code;
Tcl_ThreadId threadId = (Tcl_ThreadId) id;
/*
* Verify the thread exists.
*/
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;
}
/*
* Short circut sends to ourself. Ought to do something with -async, like
* run in an idle handler.
*/
if (threadId == Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
return Tcl_GlobalEval(interp, script);
}
/*
* Create the event for its event queue.
*/
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;
/*
* Initialize the result fields.
*/
resultPtr->done = NULL;
resultPtr->code = 0;
resultPtr->result = NULL;
resultPtr->errorInfo = NULL;
resultPtr->errorCode = NULL;
/*
* Maintain the cleanup list.
*/
resultPtr->srcThreadId = Tcl_GetCurrentThread();
resultPtr->dstThreadId = threadId;
resultPtr->eventPtr = threadEventPtr;
resultPtr->nextPtr = resultList;
if (resultList) {
resultList->prevPtr = resultPtr;
}
resultPtr->prevPtr = NULL;
resultList = resultPtr;
}
/*
* Queue the event and poke the other thread's notifier.
*/
threadEventPtr->event.proc = ThreadEventProc;
Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
TCL_QUEUE_TAIL);
Tcl_ThreadAlert(threadId);
if (!wait) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
* Block on the results and then get them.
*/
Tcl_ResetResult(interp);
while (resultPtr->result == NULL) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
/*
* Unlink result from the result list.
*/
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;
}