Tcl package Thread source code

		{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING:
    Building ${PACKAGE_NAME} without threads enabled, but building against Tcl
    that IS thread-enabled.  It is recommended to use --enable-threads." >&5
$as_echo "$as_me: WARNING:
    Building ${PACKAGE_NAME} without threads enabled, but building against Tcl
    that IS thread-enabled.  It is recommended to use --enable-threads." >&2;}
	    fi












	    ;;
    esac



#--------------------------------------------------------------------
# The statement below defines a collection of symbols related to

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "tclThreadInt.h"
#include "threadSvCmd.h"

/*
 * Provide package version in build contexts which do not provide
 * -DPACKAGE_VERSION, like building a shell with the Thread object
 * files built as part of that shell. Example: basekits.
 */
#ifndef PACKAGE_VERSION

/*
 * Structure holding result of the command executed in target thread.
 */

typedef struct ThreadEventResult {
    Tcl_Condition done;                   /* Set when the script completes */
    int code;                             /* Return value of the function */
    Tcl_Obj *result;                      /* Result from the function */
    char *errorInfo;                      /* Copy of errorInfo variable */
    char *errorCode;                      /* Copy of errorCode variable */
    Tcl_ThreadId srcThreadId;             /* Id of sender, if it dies */
    Tcl_ThreadId dstThreadId;             /* Id of target, if it dies */
    struct ThreadEvent *eventPtr;         /* Back pointer */
    struct ThreadEventResult *nextPtr;    /* List for cleanup */
    struct ThreadEventResult *prevPtr;

} ThreadEvent;

typedef int  (ThreadSendProc) (Tcl_Interp*, void *);
typedef void (ThreadSendFree) (void *);

static ThreadSendProc ThreadSendEval;     /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar;   /* Sets the named variable */
static ThreadSendProc ThreadClbkCommand;   /* Sets the named variable */

/*
 * These structures are used to communicate commands between source and target
 * threads. The ThreadSendData is used for source->target command passing,
 * while the ThreadClbkData is used for doing asynchronous callbacks.
 *
 * Important: structures below must have first three elements identical!

 */

static void
threadSendFree(void *ptr)
{
    Tcl_Free(ptr);
}

static void
threadSendObjFree(ClientData ptr)
{
    Tcl_DecrRefCount((Tcl_Obj *)ptr);
}

static int
ThreadSendObjCmd(dummy, interp, objc, objv)
    void *dummy;          /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;           /* Number of arguments. */
    Tcl_Obj    *const objv[];   /* Argument objects. */
{
    size_t size;
    int cmd = 0, ret, ii = 0, flags = 0;
    Tcl_ThreadId thrId;
    const char *script, *arg;
    Tcl_Obj *var = NULL;

    ThreadClbkData *clbkPtr = NULL;
    ThreadSendData *sendPtr = NULL;

    for (ii = 1; ii < objc; ii++) {
        arg = Tcl_GetString(objv[ii]);
        if (OPT_CMP(arg, "-async")) {
            flags &= ~THREAD_SEND_WAIT;
        } else if (OPT_CMP(arg, "-head")) {
            flags |= THREAD_SEND_HEAD;
        } else if (OPT_CMP(arg, "-command")) {
            flags &= ~THREAD_SEND_WAIT;
            cmd = 1;
        } else {
            break;
        }
    }
    if (ii >= objc) {
        goto usage;
    }
    if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) {
        return TCL_ERROR;
    }
    if (++ii >= objc) {
        goto usage;
    }

    script = Tcl_GetString(objv[ii]);
    size = objv[ii]->length+1;
    if (++ii < objc) {
        var = objv[ii];
    }
    if (var && (flags & THREAD_SEND_WAIT) == 0) {



        if (thrId == Tcl_GetCurrentThread()) {
            /*
             * FIXME: Do something for callbacks to self
             */
            Tcl_SetObjResult(interp, Tcl_NewStringObj("can't notify self", TCL_AUTO_LENGTH));
            return TCL_ERROR;
        }

        /*
         * Prepare record for the callback. This is asynchronously
         * posted back to us when the target thread finishes processing.
         * We should do a vwait on the "var" to get notified.
         */

        clbkPtr = Tcl_Alloc(sizeof(ThreadClbkData));
        if (cmd) {
            clbkPtr->execProc   = ThreadClbkCommand;
        } else {
            clbkPtr->execProc   = ThreadClbkSetVar;
        }
        clbkPtr->freeProc   = threadSendObjFree;
        clbkPtr->interp     = interp;
        clbkPtr->threadId   = Tcl_GetCurrentThread();
        clbkPtr->clientData = Sv_DuplicateObj(var);
        Tcl_IncrRefCount((Tcl_Obj *)clbkPtr->clientData);
    }

    /*
     * Prepare job record for the target thread
     */

    sendPtr = Tcl_Alloc(sizeof(ThreadSendData));

 */

static int
ThreadClbkSetVar(interp, clientData)
    Tcl_Interp *interp;
    void *clientData;
{
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    Tcl_Obj *var = (Tcl_Obj *)clbkPtr->clientData;
    Tcl_Obj *valObj;
    ThreadEventResult *resultPtr = &clbkPtr->result;
    int rc = TCL_OK;

    /*
     * Get the result of the posted command.
     * We will use it to fill-in the result variable.
     */





    valObj = resultPtr->result;


    /*
     * Set the result variable
     */

    if (Tcl_ObjSetVar2(interp, var, NULL, valObj,
                      TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
        rc = TCL_ERROR;
        goto cleanup;
    }

    /*
     * In case of error, trigger the bgerror mechansim
     */

    if (resultPtr->code == TCL_ERROR) {
        if (resultPtr->errorCode) {
            Tcl_SetVar2Ex(interp, "errorCode", NULL,
                Tcl_NewStringObj(resultPtr->errorCode, -1), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorCode);
        }
        if (resultPtr->errorInfo) {
            Tcl_SetVar2Ex(interp, "errorInfo", NULL,
                Tcl_NewStringObj(resultPtr->errorInfo, -1), TCL_GLOBAL_ONLY);
            Tcl_Free(resultPtr->errorInfo);
        }
        Tcl_SetObjResult(interp, valObj);
        Tcl_BackgroundException(interp, TCL_ERROR);
        return TCL_ERROR;
    }
    return TCL_OK;

cleanup:
    Tcl_DecrRefCount(valObj);
    return rc;
}

static int ThreadClbkCommand(Tcl_Interp *interp, ClientData clientData)
{
    int status = TCL_OK;
    ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
    Tcl_Obj *script = (Tcl_Obj *)clbkPtr->clientData;
    ThreadEventResult *resultPtr = &clbkPtr->result;

    if (resultPtr->code == TCL_ERROR) {
        Tcl_SetObjResult(interp, resultPtr->result);
        Tcl_BackgroundError(interp);
        goto cleanup;
    }

    if ((status = Tcl_ListObjAppendElement(
        interp, script, resultPtr->result)) != TCL_OK) {
        goto cleanup;
    }
    status = Tcl_GlobalEvalObj(interp, script);

cleanup:
    Tcl_DecrRefCount(resultPtr->result);
    return status;
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadCreate --
 *
 *  This procedure is invoked to create a thread containing an

        if (resultPtr->errorInfo) {
        	Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(resultPtr->errorInfo, TCL_AUTO_LENGTH));
            Tcl_Free(resultPtr->errorInfo);
        }
    }

    code = resultPtr->code;
    Tcl_SetObjResult(interp, resultPtr->result);

    /*
     * Cleanup
     */

    Tcl_ConditionFinalize(&resultPtr->done);

    Tcl_DecrRefCount(resultPtr->result);

    Tcl_Free(resultPtr);

    return code;
}

/*
 *----------------------------------------------------------------------

            if (dowait) {
                while (resultPtr->result == NULL) {
                    Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
                }
                SpliceOut(resultPtr, resultList);
                Tcl_ConditionFinalize(&resultPtr->done);
                Tcl_DecrRefCount(resultPtr->result);


                Tcl_Free(resultPtr);
            }
        }
    }

    Tcl_MutexUnlock(&threadMutex);
    Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);

static void
ThreadSetResult(interp, code, resultPtr)
    Tcl_Interp *interp;
    int code;
    ThreadEventResult *resultPtr;
{
    const char *errorCode, *errorInfo;
    size_t size;


    if (interp == NULL) {
        code      = TCL_ERROR;
        errorInfo = "";
        errorCode = "THREAD";


        resultPtr->result = Tcl_NewStringObj("no target interp", -1);

    } else {


        resultPtr->result = Sv_DuplicateObj(Tcl_GetObjResult(interp));

        if (code == TCL_ERROR) {
            errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
            errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
        } else {
            errorCode = NULL;
            errorInfo = NULL;
        }
    }
    Tcl_IncrRefCount(resultPtr->result);

    resultPtr->code = code;

    if (errorCode != NULL) {
        size = strlen(errorCode) + 1;
        resultPtr->errorCode = memcpy(Tcl_Alloc(size), errorCode, size);
    } else {

            /*
             * 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.
             */

            resultPtr->result = Tcl_NewStringObj(diemsg, -1);
            Tcl_IncrRefCount(resultPtr->result);
            resultPtr->code = TCL_ERROR;
            resultPtr->errorCode = resultPtr->errorInfo = NULL;
            Tcl_ConditionNotify(&resultPtr->done);
        }
    }
    for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
        tNextPtr = tResultPtr->nextPtr;

    thread::cond notify $cond
    after 1000
    set c2 [catch {thread::cond destroy $cond} r2]
    ThreadReap
    thread::mutex destroy $emutex
    list $c1 $c2 $r1 $r2
} {1 0 {condition variable is in use} {}}

test thread-22.1  {thread::send -command} {
    ThreadReap
    after 0 [list ::apply [list {} {
        set tid [thread::create]
        thread::send -command $tid {lindex hello} [list ::apply [list args {
            variable result
            set result $args
        } [namespace current]]]
    } [namespace current]]]
    vwait [namespace current]::result
    ThreadReap
    set result
} hello 


removeFile dummyForTransfer
::tcltest::cleanupTests