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