Beispiel #1
0
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);
    }
}
Beispiel #2
0
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;
}
Beispiel #3
0
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;
}
Beispiel #5
0
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;
}
Beispiel #6
0
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);
}
Beispiel #7
0
     /* 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);
}
Beispiel #8
0
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
}
Beispiel #9
0
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);
}
Beispiel #10
0
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);
}
Beispiel #11
0
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;
}
Beispiel #13
0
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);
}
Beispiel #15
0
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;
}
Beispiel #16
0
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;
}
Beispiel #17
0
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);
    }
}
Beispiel #18
0
  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
**
Beispiel #19
0
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;
}
Beispiel #20
0
	/* 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;
}
Beispiel #21
0
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;
}