tclthreadtest.c

来自「tcl是工具命令语言」· C语言 代码 · 共 1,030 行 · 第 1/2 页

    /*
     * Clean up.
     */

    ListRemove(tsdPtr);
    Tcl_Release((ClientData) tsdPtr->interp);
    Tcl_DeleteInterp(tsdPtr->interp);
    Tcl_ExitThread(result);

    TCL_THREAD_CREATE_RETURN;
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadErrorProc --
 *
 *    Send a message to the thread willing to hear about errors.
 *
 * Results:
 *    none
 *
 * Side effects:
 *    Send an event.
 *
 *------------------------------------------------------------------------
 */
static void
ThreadErrorProc(interp)
    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);
    }
}


/*
 *------------------------------------------------------------------------
 *
 * ListUpdateInner --
 *
 *    Add the thread local storage to the list.  This assumes
 *	the caller has obtained the mutex.
 *
 * Results:
 *    none
 *
 * Side effects:
 *    Add the thread local storage to its list.
 *
 *------------------------------------------------------------------------
 */
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;
}

/*
 *------------------------------------------------------------------------
 *
 * ListRemove --
 *
 *    Remove the thread local storage from its list.  This grabs the
 *	mutex to protect the list.
 *
 * Results:
 *    none
 *
 * Side effects:
 *    Remove the thread local storage from its list.
 *
 *------------------------------------------------------------------------
 */
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);
}


/*
 *------------------------------------------------------------------------
 *
 * TclThreadList --
 *
 *    Return a list of threads running Tcl interpreters.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
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;
}


/*
 *------------------------------------------------------------------------
 *
 * TclThreadSend --
 *
 *    Send a script to another thread.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
int
TclThreadSend(interp, id, script, wait)
    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;
}


/*
 *------------------------------------------------------------------------
 *
 * ThreadEventProc --
 *
 *    Handle the event in the target thread.
 *
 * Results:
 *    Returns 1 to indicate that the event was processed.
 *
 * Side effects:
 *    Fills out the ThreadEventResult struct.
 *
 *------------------------------------------------------------------------
 */
static int
ThreadEventProc(evPtr, mask)
    Tcl_Event *evPtr;		/* Really ThreadEvent */
    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;
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadFreeProc --
 *
 *    This is called from when we are exiting and memory needs
 *    to be freed.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *	Clears up mem specified in ClientData
 *
 *------------------------------------------------------------------------
 */
     /* ARGSUSED */
static void
ThreadFreeProc(clientData)
    ClientData clientData;
{
    if (clientData) {
	ckfree((char *) clientData);
    }
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadDeleteEvent --
 *
 *    This is called from the ThreadExitProc to delete memory related
 *    to events that we put on the queue.
 *
 * Results:
 *    1 it was our event and we want it removed, 0 otherwise.
 *
 * Side effects:
 *	It cleans up our events in the event queue for this thread.
 *
 *------------------------------------------------------------------------
 */
     /* ARGSUSED */
static int
ThreadDeleteEvent(eventPtr, clientData)
    Tcl_Event *eventPtr;		/* Really ThreadEvent */
    ClientData clientData;		/* dummy */
{
    if (eventPtr->proc == ThreadEventProc) {
	ckfree((char *) ((ThreadEvent *) eventPtr)->script);
	return 1;
    }
    /*
     * If it was NULL, we were in the middle of servicing the event
     * and it should be removed
     */
    return (eventPtr->proc == NULL);
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadExitProc --
 *
 *    This is called when the thread exits.  
 *
 * Results:
 *    None.
 *
 * Side effects:
 *	It unblocks anyone that is waiting on a send to this thread.
 *	It cleans up any events in the event queue for this thread.
 *
 *------------------------------------------------------------------------
 */
     /* ARGSUSED */
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) {
	    /*
	     * 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);
}

#endif /* TCL_THREADS */