Tcl Source Code

2011-11-25  Donal K. Fellows  <[email protected]>

	* library/history.tcl (history): Simplify the dance of variable
	management used when chaining to the implementation command.

2011-11-22  Donal K. Fellows  <[email protected]>

	* generic/tclExecute.c (TclCompileObj): Simplify and de-indent the
	logic so that it is easier to comprehend.

2011-11-22  Jan Nijtmans  <[email protected]>

	* win/tclWinPort.h:   [Bug 2935503]: Windows: file mtime
	* win/tclWinFile.c:  sets wrong time (VS2005+ only)
	* generic/tclTest.c:

2011-11-20  Joe Mistachkin  <[email protected]>

	* tests/thread.test: Remove unnecessary [after] calls from the thread
	tests.  Make error message matching more robust for tests that may
	have built-in race conditions.  Test thread-7.26 must first unset all
	thread testing related variables.  Revise results of the thread-7.28
	through thread-7.31 tests to account for the fact they are canceled
	via a script sent to the thread asynchronously, which then impacts the
	error message handling.  Attempt to manually drain the event queue for
	the main thread after joining the test thread to make sure no stray
	events are processed at the wrong time on the main thread.  Revise all
	the synchronization and comparison semantics related to the thread id
	and error message.

2011-11-18  Joe Mistachkin  <[email protected]>

	* tests/thread.test: Remove all use of thread::release from the thread
	7.x tests, replacing it with a script that can easily cause "stuck"
	threads to self-destruct for those test cases that require it.  Also,
	make the error message handling far more robust by keeping track of
	every asynchronous error.

2011-11-17  Joe Mistachkin  <[email protected]>

	* tests/thread.test: Refactor all the remaining thread-7.x tests that
	were using [testthread].  Note that this test file now requires the
	very latest version of the Thread package to pass all tests.  In
	addition, the thread-7.18 and thread-7.19 tests have been flagged as
	knownBug because they cannot pass without modifications to the [expr]
	command, persuant to TIP #392.

2011-11-17  Joe Mistachkin  <[email protected]>

	* generic/tclThreadTest.c: For [testthread cancel], avoid creating a
	new Tcl_Obj when the default script cancellation result is desired.

2011-11-11  Donal K. Fellows  <[email protected]>

	* win/tclWinConsole.c: Refactor common thread handling patterns.

2011-11-11  Alexandre Ferrieux  <[email protected]>

	* tests/zlib.test: [Bug 3428756]: Use nonblocking writes in

    int word)			/* Index of the word which is in objPtr. */
{
    Interp *iPtr = (Interp *) interp;
    int result;

    /*
     * This function consists of three independent blocks for: direct
     * evaluation of canonical lists, compilation and bytecode execution and
     * finally direct evaluation. Precisely one of these blocks will be run.
     */

    if (TclListObjIsCanonical(objPtr)) {
	Tcl_Obj *listPtr = objPtr;
	CmdFrame *eoFramePtr = NULL;
	int objc;

				/* -----------------------------------------*/
    const unsigned char *pc;	/* These fields are used on return TO this */
    ptrdiff_t *catchTop;	/* this level: they record the state when a */
    int cleanup;		/* new codePtr was received for NR */
    Tcl_Obj *auxObjList;	/* execution. */
    int checkInterp;
    CmdFrame cmdFrame;
    void *stack[1];		/* Start of the actual combined catch and obj
				 * stacks; the struct will be expanded as
				 * necessary */
} TEBCdata;

#define TEBC_YIELD() \
    do {								\
	esPtr->tosPtr = tosPtr;						\
	TD->pc = pc;							\
	TD->cleanup = cleanup;						\
	TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \

    } while (0)

#define TEBC_DATA_DIG() \
    do {					\
	pc = TD->pc;				\
	cleanup = TD->cleanup;			\
	tosPtr = esPtr->tosPtr;			\
    } while (0)

#define PUSH_TAUX_OBJ(objPtr) \
    do {							\
	objPtr->internalRep.ptrAndLongRep.ptr = auxObjList;	\
	auxObjList = objPtr;					\
    } while (0)

 * Macros used to trace instruction execution. The macros TRACE,
 * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
 * only used in TRACE* calls to get a string from an object.
 */

#ifdef TCL_COMPILE_DEBUG
#   define TRACE(a) \
    while (traceInstructions) {					\
	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels,	\
		(int) CURR_DEPTH,				\
		(unsigned) (pc - codePtr->codeStart),		\
		GetOpcodeName(pc));				\
	printf a;						\
	break;							\
    }
#   define TRACE_APPEND(a) \
    while (traceInstructions) {		\
	printf a;			\
	break;				\
    }
#   define TRACE_WITH_OBJ(a, objPtr) \
    while (traceInstructions) {					\
	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels,	\
		(int) CURR_DEPTH,				\
		(unsigned) (pc - codePtr->codeStart),		\
		GetOpcodeName(pc));				\
	printf a;						\
	TclPrintObject(stdout, objPtr, 30);			\
	fprintf(stdout, "\n");					\

/*
 * DTrace instruction probe macros.
 */

#define TCL_DTRACE_INST_NEXT() \
    do {								\
	if (TCL_DTRACE_INST_DONE_ENABLED()) {				\
	    if (curInstName) {						\
		TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH,	\
			tosPtr);					\
	    }								\
	    curInstName = tclInstructionTable[*pc].name;		\
	    if (TCL_DTRACE_INST_START_ENABLED()) {			\
		TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH,	\
			tosPtr);					\
	    }								\
	} else if (TCL_DTRACE_INST_START_ENABLED()) {			\
	    TCL_DTRACE_INST_START(tclInstructionTable[*pc].name,	\
			(int) CURR_DEPTH, tosPtr);			\
	}								\
    } while (0)
#define TCL_DTRACE_INST_LAST() \
    do {								\
	if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {		\
	    TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
	}								\
    } while (0)

/*
 * Macro used in this file to save a function call for common uses of
 * TclGetNumberFromObj(). The ANSI C "prototype" is:

	    break;
	}
    }
    if (esPtr->prevPtr) {
	eePtr->execStackPtr = esPtr->prevPtr;
    } else {
	eePtr->execStackPtr = esPtr;
    }
}

void *
TclStackAlloc(
    Tcl_Interp *interp,
    int numBytes)
{

}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileObj --
 *
 *	This procedure compiles the script contained in a Tcl_Obj.
 *
 * Results:
 *	A pointer to the corresponding ByteCode, never NULL.
 *
 * Side effects:
 *	The object is shimmered to bytecode type.
 *
 *----------------------------------------------------------------------
 */

ByteCode *
TclCompileObj(
    Tcl_Interp *interp,

	 */

	codePtr = objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
		|| (codePtr->compileEpoch != iPtr->compileEpoch)
		|| (codePtr->nsPtr != namespacePtr)
		|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
	    if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
		goto recompileObj;
	    }
	    if ((Interp *) *codePtr->interpHandle != iPtr) {
		Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");
	    }
	    codePtr->compileEpoch = iPtr->compileEpoch;


	}



	/*
	 * Check that any compiled locals do refer to the current proc
	 * environment! If not, recompile.
	 */

	if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) &&
		(codePtr->procPtr == NULL) &&
		(codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){
	    goto recompileObj;

	}

	/*
	 * #280.
	 * Literal sharing fix. This part of the fix is not required by 8.4
	 * nor 8.5, because they eval-direct any literals, so just saving the
	 * argument locations per command in bytecode is enough, embedded

	 *     offset between saved starting line and actual one. Then modify
	 *     the users to adjust the locations they have by this offset.
	 *
	 * (3) Alternative 2: Do not fully recompile, adjust just the location
	 *     information.
	 */

	if (invoker == NULL) {
	    return codePtr;

	} else {

	    Tcl_HashEntry *hePtr =
		    Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
	    ExtCmdLoc *eclPtr;
	    CmdFrame *ctxCopyPtr;
	    int redo;

	    if (!hePtr) {
		return codePtr;
	    }

	    eclPtr = Tcl_GetHashValue(hePtr);
	    redo = 0;
	    ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame));
	    *ctxCopyPtr = *invoker;

	    if (invoker->type == TCL_LOCATION_BC) {
		/*
		 * Note: Type BC => ctx.data.eval.path    is not used.
		 *		    ctx.data.tebc.codePtr used instead
		 */

		TclGetSrcInfoForPc(ctxCopyPtr);
		if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) {
		    /*
		     * The reference made by 'TclGetSrcInfoForPc' is dead.
		     */

		    Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
		    ctxCopyPtr->data.eval.path = NULL;
		}
	    }

	    if (word < ctxCopyPtr->nline) {
		/*
		 * Note: We do not care if the line[word] is -1. This is a
		 * difference and requires a recompile (location changed from
		 * absolute to relative, literal is used fixed and through
		 * variable)
		 *
		 * Example:
		 * test info-32.0 using literal of info-24.8
		 *     (dict with ... vs           set body ...).
		 */

		redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
			    && (eclPtr->start != ctxCopyPtr->line[word]))
			|| ((eclPtr->type == TCL_LOCATION_BC)
			    && (ctxCopyPtr->type == TCL_LOCATION_SOURCE));
	    }

	    TclStackFree(interp, ctxCopyPtr);
	    if (!redo) {
		return codePtr;
	    }
	}
    }

  recompileObj:
    iPtr->errorLine = 1;

    /*
     * TIP #280. Remember the invoker for a moment in the interpreter
     * structures so that the byte code compiler can pick it up when
     * initializing the compilation environment, i.e. the extended location
     * information.
     */

    iPtr->invokeCmdFramePtr = invoker;
    iPtr->invokeWord = word;
    TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
    iPtr->invokeCmdFramePtr = NULL;
    codePtr = objPtr->internalRep.otherValuePtr;
    if (iPtr->varFramePtr->localCachePtr) {
	codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
	codePtr->localCachePtr->refCount++;
    }
    return codePtr;

 *	Almost certainly, depending on the ByteCode's instructions.
 *
 *----------------------------------------------------------------------
 */
#define	bcFramePtr	(&TD->cmdFrame)
#define	initCatchTop	((ptrdiff_t *) (&TD->stack[-1]))
#define	initTosPtr	((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
#define esPtr		(iPtr->execEnvPtr->execStackPtr)

int
TclNRExecuteByteCode(
    Tcl_Interp *interp,		/* Token for command interpreter. */
    ByteCode *codePtr)		/* The bytecode sequence to interpret. */
{
    Interp *iPtr = (Interp *) interp;
    TEBCdata *TD;
    int size = sizeof(TEBCdata) - 1
	    + (codePtr->maxStackDepth + codePtr->maxExceptDepth)
		* sizeof(void *);
    int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);

    if (iPtr->execEnvPtr->rewind) {
	return TCL_ERROR;
    }

    codePtr->refCount++;

    /*
     * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
     *
     * The execution uses a unified stack: first a TEBCdata, immediately
     * above it a CmdFrame, then the catch stack, then the execution stack.
     *
     * Make sure the catch stack is large enough to hold the maximum number of
     * catch commands that could ever be executing at the same time (this will
     * be no more than the exception range array's depth). Make sure the
     * execution stack is large enough to execute this ByteCode.
     */

    TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0);
    esPtr->tosPtr = initTosPtr;

    TD->codePtr     = codePtr;
    TD->pc	    = codePtr->codeStart;
    TD->catchTop    = initCatchTop;
    TD->cleanup     = 0;
    TD->auxObjList  = NULL;
    TD->checkInterp = 0;

    /*
     * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
     * every time that we call out from this TD, popped when we return to it.
     */

    bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
	    ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);

#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

    /*
     * Push the callback for bytecode execution
     */

    TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
	    NULL, NULL);
    return TCL_OK;
}

static int
TEBCresume(

    int instructionCount = 0;	/* Counter that is used to work out when to
				 * call Tcl_AsyncReady() */
    const char *curInstName;
#ifdef TCL_COMPILE_DEBUG
    int traceInstructions;	/* Whether we are doing instruction-level
				 * tracing or not. */
#endif

    Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
    Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];

#define LOCAL(i)	(&compiledLocals[(i)])
#define TCONST(i)	(constants[(i)])

    /*
     * These macros are just meant to save some global variables that are not
     * used too frequently
     */

    TEBCdata *TD = data[0];
#define auxObjList	(TD->auxObjList)
#define catchTop	(TD->catchTop)
#define codePtr		(TD->codePtr)
#define checkInterp	(TD->checkInterp)
			/* Indicates when a check of interp readyness is
			 * necessary. Set by CACHE_STACK_INFO() */

    /*
     * Globals: variables that store state, must remain valid at all times.
     */

    Tcl_Obj **tosPtr;		/* Cached pointer to top of evaluation
				 * stack. */
    const unsigned char *pc;	/* The current program counter. */

    /*
     * Transfer variables - needed only between opcodes, but not while
     * executing an instruction.
     */

    int cleanup = 0;

		NEXT_INST_V(1, cleanup, 0);
	    }
#endif
	    /*
	     * Push the call's object result and continue execution with the
	     * next instruction.
	     */

	    TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
		    objc, cmdNameBuf), Tcl_GetObjResult(interp));

	    objResultPtr = Tcl_GetObjResult(interp);

	    /*
	     * Reset the interp's result to avoid possible duplications of
	     * large objects [Bug 781585]. We do not call Tcl_ResetResult to
	     * avoid any side effects caused by the resetting of errorInfo and
	     * errorCode [Bug 804681], which are not needed here. We chose
	     * instead to manipulate the interp's object result directly.
	     *
	     * Note that the result object is now in objResultPtr, it keeps
	     * the refCount it had in its role of iPtr->objResultPtr.
	     */

	    TclNewObj(objPtr);
	    Tcl_IncrRefCount(objPtr);
	    iPtr->objResultPtr = objPtr;
	    NEXT_INST_V(0, cleanup, -1);
	}

	/*
	 * Result not TCL_OK: fall through
	 */
    }

    if (iPtr->execEnvPtr->rewind) {
	result = TCL_ERROR;
	goto abnormalReturn;
    }

    if (result != TCL_OK) {
	pc--;

	value2Ptr = OBJ_AT_TOS;
	valuePtr = OBJ_UNDER_TOS;
	if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) {
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
	    DECACHE_STACK_INFO();
	    IllegalExprOperandType(interp, pc, valuePtr);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

	if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) {
	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
		    (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
	    DECACHE_STACK_INFO();
	    IllegalExprOperandType(interp, pc, value2Ptr);
	    CACHE_STACK_INFO();
	    goto gotError;
	}

	if (*pc == INST_LOR) {
	    iResult = (i1 || i2);
	} else {
	    iResult = (i1 && i2);

	    if (TclIsPureByteArray(valuePtr)
		    && TclIsPureByteArray(value2Ptr)) {
		s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
		s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
		memCmpFn = memcmp;
	    } else if (((valuePtr->typePtr == &tclStringType)
		    && (value2Ptr->typePtr == &tclStringType))) {
		/*
		 * Do a unicode-specific comparison if both of the args are of
		 * String type. If the char length == byte length, we can do a
		 * memcmp. In benchmark testing this proved the most efficient
		 * check between the unicode and string comparison operations.
		 */

	    goto gotError;
	}
	/* TODO: Consider peephole opt. */
	objResultPtr = TCONST(!b);
	NEXT_INST_F(1, 1, 1);
    }

    case INST_BITNOT:
	valuePtr = OBJ_AT_TOS;
	if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
		|| (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
	    /*
	     * ... ~$NonInteger => raise an error.
	     */

	/*
	 * Division by zero in an expression. Control only reaches this point
	 * by "goto divideByZero".
	 */

    divideByZero:
	DECACHE_STACK_INFO();
	Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
	CACHE_STACK_INFO();
	goto gotError;

	/*
	 * Exponentiation of zero by negative number in an expression. Control
	 * only reaches this point by "goto exponOfZero".
	 */

    exponOfZero:
	DECACHE_STACK_INFO();
	Tcl_SetResult(interp, "exponentiation of zero by negative power",
		TCL_STATIC);
	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
		"exponentiation of zero by negative power", NULL);
	CACHE_STACK_INFO();

	/*

	/*
	 * Clear all expansions that may have started after the last
	 * INST_BEGIN_CATCH.
	 */

	while (auxObjList) {
	    if ((catchTop != initCatchTop)
		    && (*catchTop > (ptrdiff_t)
			auxObjList->internalRep.ptrAndLongRep.value)) {
		break;
	    }
	    POP_TAUX_OBJ();
	}

	/*
	 * We must not catch if the script in progress has been canceled with

    Interp *iPtr,
    int *lenPtr)
{
    CmdFrame *cfPtr = iPtr->cmdFramePtr;
    ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;

    return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
	    codePtr, lenPtr, NULL);
}

void
TclGetSrcInfoForPc(
    CmdFrame *cfPtr)
{
    ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;

    }
}

static const char *
GetSrcInfoForPc(
    const unsigned char *pc,	/* The program counter value for which to
				 * return the closest command's source info.
				 * This points within a bytecode instruction
				 * in codePtr's code. */
    ByteCode *codePtr,		/* The bytecode sequence in which to look up
				 * the command source for the pc. */
    int *lengthPtr,		/* If non-NULL, the location where the length
				 * of the command's source should be stored.
				 * If NULL, no length is stored. */
    const unsigned char **pcBeg)/* If non-NULL, the bytecode location
				 * where the current instruction starts.

		bestSrcOffset = srcOffset;
		bestSrcLength = srcLen;
	    }
	}
    }

    if (pcBeg != NULL) {
	const unsigned char *curr, *prev;

	/*
	 * Walk from beginning of command or BC to pc, by complete
	 * instructions. Stop when crossing pc; keep previous.
	 */

	curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist);


	prev = curr;
	while (curr <= pc) {
	    prev = curr;
	    curr += tclInstructionTable[*curr].numBytes;
	}
	*pcBeg = prev;
    }

    if (bestDist == INT_MAX) {
	return NULL;
    }

    if (lengthPtr != NULL) {

 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Copyright (c) 2003 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */



#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
#   define USE_TCL_STUBS
#endif
#include "tclInt.h"
#include "tclOO.h"
#include <math.h>

/*
 * Required for Testregexp*Cmd
 */
#include "tclRegexp.h"

/*
 * Required for TestlocaleCmd

    /*
     * Since Tcl_CancelEval can be safely called from any thread,
     * we do it now.
     */

    Tcl_MutexUnlock(&threadMutex);
    Tcl_ResetResult(interp);
    return Tcl_CancelEval(tsdPtr->interp,
    	(result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadEventProc --
 *

    # given at all.

    if {![llength $args]} {
	set args info
    }

    # Tricky stuff needed to make stack and errors come out right!
    tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
}

# tcl::HistAdd --
#
#	Add an item to the history, and optionally eval it at the global scope
#
# Parameters:

    package require tcltest 2.2
    namespace import -force ::tcltest::*
}

# Some tests require the testthread command

testConstraint testthread [expr {[info commands testthread] != {}}]

# Some tests require the Thread package

testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}]

# Some tests may not work under valgrind

testConstraint notValgrind [expr {![testConstraint valgrind]}]

set threadSuperKillScript {
    rename catch ""
    rename while ""
    rename unknown ""
    rename update ""
    thread::release
}

proc getThreadErrorFromInfo { info } {
    set list [split $info \n]
    set idx [lsearch -glob $list "*eval*unwound*"]
    if {$idx != -1} then {
        return [lindex $list $idx]
    }
    set idx [lsearch -glob $list "*eval*canceled*"]
    if {$idx != -1} then {
        return [lindex $list $idx]
    }
    return ""; # some other error we do not care about.
}

proc findThreadError { info } {
    foreach error [lreverse $info] {
        set error [getThreadErrorFromInfo $error]
        if {[string length $error] > 0} then {
            return $error
        }
    }
    return ""; # some other error we do not care about.
}

proc ThreadError {id info} {
    global threadSawError
    if {[string length [getThreadErrorFromInfo $info]] > 0} then {
        global threadId threadError
        set threadId $id
        lappend threadError($id) $info
    }
    set threadSawError($id) true; # signal main thread to exit [vwait].
}

if {[testConstraint thread]} {
    thread::errorproc ThreadError
}

if {[testConstraint testthread]} {
    proc drainEventQueue {} {
	while {[set x [testthread event]]} {
	    puts "WARNING: drained $x event(s) on main thread"
	}
    }

    testthread errorproc ThreadError

    set mainThread [testthread id]

    proc ThreadNullError {id info} {
	# ignore
    }

	    after 1
	}
	testthread errorproc ThreadError
	return [llength [testthread names]]
    }
}

# Some tests require manual draining of the event queue

testConstraint drainEventQueue [expr {[info commands drainEventQueue] != {}}]

test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
    llength [thread::names]
} 1
test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} {
    set serverthread [thread::create -preserved]
    set numthreads [llength [thread::names]]
    thread::release $serverthread

	}
	unset x
    }
    thread::release -wait $serverthread
} 0

# TIP #285: Script cancellation support
test thread-7.4 {cancel: pure bytecode loop} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.5 {cancel: pure inside-command loop} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    set while while
	    $while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    set while while
	    $while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.8 {cancel: pure bytecode loop custom result} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread "the eval was canceled"]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was canceled}}
test thread-7.9 {cancel: pure inside-command loop custom result} -constraints {
    thread
    drainEventQueue
} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    set while while
	    $while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread "the eval was canceled"]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was canceled}}
test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints {
    thread
    drainEventQueue
} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread "the eval was unwound"]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue





















































































































































































    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was unwound}}
test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints {
    thread
    drainEventQueue
} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    set while while
	    $while {1} {
		# No bytecode at all here...
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread "the eval was unwound"]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {the eval was unwound}}
test thread-7.12 {cancel: after} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	if {![info exists foo]} then {
	    # signal the primary thread that we are ready
	    # to be canceled now (we are running).
	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
	    set foo 1
	}
	after 30000
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.13 {cancel: after -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	if {![info exists foo]} then {
	    # signal the primary thread that we are ready
	    # to be canceled now (we are running).
	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
	    set foo 1
	}
	after 30000
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID [thread::id]] {
	if {![info exists foo]} then {
	    # signal the primary thread that we are ready
	    # to be canceled now (we are running).
	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
	    set foo 1
	}
	vwait forever
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.15 {cancel: vwait -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	if {![info exists foo]} then {
	    # signal the primary thread that we are ready
	    # to be canceled now (we are running).
	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
	    set foo 1
	}
	vwait forever
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID [thread::id]] {
	set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
	$i eval {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).

		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    expr {[while {1} {incr x}]}
	}
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.17 {cancel: expr -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
	$i eval {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    expr {[while {1} {incr x}]}
	}
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.18 {cancel: expr bignum} {thread drainEventQueue knownBug} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
        set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
        $i eval {
            if {![info exists foo]} then {
                # signal the primary thread that we are ready
                # to be canceled now (we are running).

                thread::send %ID% [list set ::threadIdStarted [thread::id]]
                set foo 1
            }
            #
            # BUGBUG: This will not cancel because libtommath
            #         does not check Tcl_Canceled.
            #
            expr {2**99999}
        }
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread); # WARNING: Never returns (see above).

    thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above).
    list $res [expr {[info exists ::threadIdStarted] ? \
                  $::threadIdStarted == $serverthread : 0}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 0 {}}
test thread-7.19 {cancel: expr bignum -unwind} {thread drainEventQueue knownBug} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
        set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
        $i eval {
            if {![info exists foo]} then {
                # signal the primary thread that we are ready
                # to be canceled now (we are running).

                thread::send %ID% [list set ::threadIdStarted [thread::id]]
                set foo 1
            }
            #
            # BUGBUG: This will not cancel because libtommath
            #         does not check Tcl_Canceled.
            #
            expr {2**99999}
        }
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread); # WARNING: Never returns (see above).

    thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above).
    list $res [expr {[info exists ::threadIdStarted] ? \
                  $::threadIdStarted == $serverthread : 0}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 0 {}}
test thread-7.20 {cancel: subst} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
	$i eval {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    subst {[while {1} {incr x}]}
	}
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
	$i eval {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    subst {[while {1} {incr x}]}
	}
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
	$i eval {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    while {1} {}
	}
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	set i [interp create]
	$i eval "package require -exact Thread [package present Thread]"
	$i eval {
	    if {![info exists foo]} then {
		# signal the primary thread that we are ready
		# to be canceled now (we are running).
		thread::send %ID% [list set ::threadIdStarted [thread::id]]
		set foo 1
	    }
	    set while while; $while {1} {}
	}
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainEventQueue} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready
		    # to be canceled now (we are running).

		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
		    set foo 1
		}
		catch {
		    while {1} {
			catch {
			    while {1} {
				# we must call update here because otherwise
				# the thread cannot even be forced to exit.
				update
			    }
			}
		    }
		}
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::cancel $serverthread]

    thread::send $serverthread $::threadSuperKillScript
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {[info exists ::threadIdStarted] ? \
		  $::threadIdStarted == $serverthread : 0}] \
	      [expr {[info exists ::threadId] ? \
		  $::threadId == $serverthread : 0}] \
	      [expr {[info exists ::threadError($serverthread)] ? \
		  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 0 {}}
test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread drainEventQueue} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    set catch catch
	    set while while
	    $while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready
		    # to be canceled now (we are running).

		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
		    set foo 1
		}
		$catch {
		    $while {1} {
			$catch {
			    $while {1} {
				# we must call update here because otherwise
				# the thread cannot even be forced to exit.
				update
			    }
			}
		    }
		}
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::cancel $serverthread]

    thread::send $serverthread $::threadSuperKillScript
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {[info exists ::threadIdStarted] ? \
		  $::threadIdStarted == $serverthread : 0}] \
	      [expr {[info exists ::threadId] ? \
		  $::threadId == $serverthread : 0}] \
	      [expr {[info exists ::threadError($serverthread)] ? \
		  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 0 {}}
test thread-7.26 {cancel: send async cancel bad interp path} {thread drainEventQueue} {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	[string map [list %ID% [thread::id]] {
	proc foobar {} {
	    while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready
		    # to be canceled now (we are running).
		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
		    set foo 1
		}
		update
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    catch {thread::send $serverthread {interp cancel -- bad}} msg
    thread::send -async $serverthread {interp cancel -unwind}
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list [expr {$::threadIdStarted == $serverthread}] $msg
} {1 {could not find interpreter "bad"}}
test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	set i [interp create -- -unwind]
	$i eval "package require -exact Thread [package present Thread]"
	$i eval {
	    proc foobar {} {

	    }
	    foobar
	}
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::send -async $serverthread {interp cancel -- -unwind}]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval canceled}}
test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread drainEventQueue} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready
		    # to be canceled now (we are running).

		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
		    set foo 1
		}
		catch {
		    while {1} {
			catch {
			    while {1} {
				# we must call update here because otherwise
				# the thread cannot even be forced to exit.
				update
			    }
			}
		    }
		}
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::send -async $serverthread {interp cancel}]

    thread::send $serverthread $::threadSuperKillScript
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {[info exists ::threadIdStarted] ? \
		  $::threadIdStarted == $serverthread : 0}] \
	      [expr {[info exists ::threadId] ? \
		  $::threadId == $serverthread : 0}] \
	      [expr {[info exists ::threadError($serverthread)] ? \
		  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 1 {eval canceled}}
test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread drainEventQueue} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    set catch catch
	    set while while
	    $while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready
		    # to be canceled now (we are running).

		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
		    set foo 1
		}
		$catch {
		    $while {1} {
			$catch {
			    $while {1} {
				# we must call update here because otherwise
				# the thread cannot even be forced to exit.
				update
			    }
			}
		    }
		}
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::send -async $serverthread {interp cancel}]

    thread::send $serverthread $::threadSuperKillScript
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {[info exists ::threadIdStarted] ? \
		  $::threadIdStarted == $serverthread : 0}] \
	      [expr {[info exists ::threadId] ? \
		  $::threadId == $serverthread : 0}] \
	      [expr {[info exists ::threadError($serverthread)] ? \
		  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 1 {eval canceled}}
test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread drainEventQueue} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready
		    # to be canceled now (we are running).

		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
		    set foo 1
		}
		catch {
		    while {1} {
			catch {
			    while {1} {
				# we must call update here because otherwise
				# the thread cannot even be forced to exit.
				update
			    }
			}
		    }
		}
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::send -async $serverthread {thread::cancel [thread::id]}]

    thread::send $serverthread $::threadSuperKillScript
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {[info exists ::threadIdStarted] ? \
		  $::threadIdStarted == $serverthread : 0}] \
	      [expr {[info exists ::threadId] ? \
		  $::threadId == $serverthread : 0}] \
	      [expr {[info exists ::threadError($serverthread)] ? \
		  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 1 {eval canceled}}
test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread drainEventQueue} {

    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    set catch catch
	    set while while
	    $while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready
		    # to be canceled now (we are running).

		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
		    set foo 1
		}
		$catch {
		    $while {1} {
			$catch {
			    $while {1} {
				# we must call update here because otherwise
				# the thread cannot even be forced to exit.
				update
			    }
			}
		    }
		}
	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted; after 1000
    set res [thread::send -async $serverthread {thread::cancel [thread::id]}]

    thread::send $serverthread $::threadSuperKillScript
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {[info exists ::threadIdStarted] ? \
		  $::threadIdStarted == $serverthread : 0}] \
	      [expr {[info exists ::threadId] ? \
		  $::threadId == $serverthread : 0}] \
	      [expr {[info exists ::threadError($serverthread)] ? \
		  [findThreadError $::threadError($serverthread)] : ""}]
} {{} 1 1 {eval canceled}}
test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready

	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    set catch catch
	    set while while
	    $while {1} {

	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::cancel -unwind $serverthread]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready

	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::send -async $serverthread {interp cancel -unwind}]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    set catch catch
	    set while while
	    $while {1} {

	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::send -async $serverthread {interp cancel -unwind}]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID% [thread::id]] {
	proc foobar {} {
	    while {1} {
		if {![info exists foo]} then {
		    # signal the primary thread that we are ready

	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}
test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
    set serverthread [thread::create -joinable \
	    [string map [list %ID [thread::id]] {
	proc foobar {} {
	    set catch catch
	    set while while
	    $while {1} {

	    }
	}
	foobar
    }]]
    # wait for other thread to signal "ready to cancel"
    vwait ::threadIdStarted
    set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
    vwait ::threadSawError($serverthread)
    thread::join $serverthread; drainEventQueue
    list $res [expr {$::threadIdStarted == $serverthread}] \
              [expr {[info exists ::threadId] ? \
                  $::threadId == $serverthread : 0}] \
              [expr {[info exists ::threadError($serverthread)] ? \
                  [findThreadError $::threadError($serverthread)] : ""}]
} -cleanup {
    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -result {{} 1 1 {eval unwound}}

# cleanup
::tcltest::cleanupTests
return

 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */




#include "tclWinInt.h"
#include "tclFileSystem.h"
#include <winioctl.h>
#include <sys/stat.h>
#include <shlobj.h>
#include <lm.h>		/* For TclpGetUserHome(). */

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

#ifndef _TCLWINPORT
#define _TCLWINPORT

#ifndef _WIN64
/* See [Bug 2935503]: file mtime sets wrong time */
#   define _USE_32BIT_TIME_T
#endif

/*
 * We must specify the lower version we intend to support.
 *
 * WINVER = 0x0500 means Windows 2000 and above
 */