Tcl Source Code

static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;


MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
................................................................................

    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;


    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);



    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
    }

................................................................................
	    /*
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}


	/* An existing command conflicts. Try to delete it.. */


	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * Be careful to preserve
	 * any existing import links so we can restore them down below. That
	 * way, you can redefine a command and its import status will remain
	 * intact.
	 */

	cmdPtr->refCount++;
	if (cmdPtr->importRefPtr) {
	    cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
	}

................................................................................
	}
	TclCleanupCommandMacro(cmdPtr);
	deleted = 1;
    }

    if (!isNew) {
	/*
	 * If the deletion callback recreated the command, just throw away
	 * the new command (if we try to delete it again, we could get
	 * stuck in an infinite loop).
	 */

	Tcl_Free(Tcl_GetHashValue(hPtr));
    }

    if (!deleted) {

	/*
	 * Command resolvers (per-interp, per-namespace) might have resolved
	 * to a command for the given namespace scope with this command not
	 * being registered with the namespace's command table. During BC
	 * compilation, the so-resolved command turns into a CmdName literal.
	 * Without invalidating a possible CmdName literal here explicitly,
	 * such literals keep being reused while pointing to overhauled
................................................................................
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}

	/*
         * An existing command conflicts. Try to delete it.
         */

	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * Command already exists; delete it. Be careful to preserve any
	 * existing import links so we can restore them down below. That way,
................................................................................
    /*
     * Lookup the Command to dispatch.
     */

    reresolve:
    assert(cmdPtr == NULL);
    if (preCmdPtr) {

	/* Caller gave it to us */


	if (!(preCmdPtr->flags & CMD_IS_DELETED)) {

	    /* So long as it exists, use it. */


	    cmdPtr = preCmdPtr;
	} else if (flags & TCL_EVAL_NORESOLVE) {
	    /*
	     * When it's been deleted, and we're told not to attempt
	     * resolving it ourselves, all we can do is raise an error.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "attempt to invoke a deleted command"));
	    Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
	    return TCL_ERROR;
	}
    }
    if (cmdPtr == NULL) {
................................................................................
	if (!cmdPtr) {
	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
	}
    }

    if (enterTracesDone || iPtr->tracePtr
	    || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {

	Tcl_Obj *commandPtr = TclGetSourceFromFrame(
		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
		objc, objv);
	Tcl_IncrRefCount(commandPtr);


	if (!enterTracesDone) {

	    int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
		    objc, objv);

	    /*
	     * Send any exception from enter traces back as an exception
	     * raised by the traced command.
	     * TODO: Is this a bug?  Letting an execution trace BREAK or
	     * CONTINUE or RETURN in the place of the traced command?
	     * Would either converting all exceptions to TCL_ERROR, or
	     * just swallowing them be better?  (Swallowing them has the
	     * problem of permanently hiding program errors.)
	     */

	    if (code != TCL_OK) {
		Tcl_DecrRefCount(commandPtr);
		return code;
	    }

	    /*
	     * If the enter traces made the resolved cmdPtr unusable, go
	     * back and resolve again, but next time don't run enter
	     * traces again.
	     */

	    if (cmdPtr == NULL) {
		enterTracesDone = 1;
		Tcl_DecrRefCount(commandPtr);
		goto reresolve;
	    }
	}

	/*
	 * Schedule leave traces.  Raise the refCount on the resolved
	 * cmdPtr, so that when it passes to the leave traces we know
	 * it's still valid.
	 */

	cmdPtr->refCount++;
	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
		    commandPtr, cmdPtr, objv);
    }

................................................................................
TclNRRunCallbacks(
    Tcl_Interp *interp,
    int result,
    struct NRE_callback *rootPtr)
				/* All callbacks down to rootPtr not inclusive
				 * are to be run. */
{

    NRE_callback *callbackPtr;
    Tcl_NRPostProc *procPtr;

    while (TOP_CB(interp) != rootPtr) {
	callbackPtr = TOP_CB(interp);
	procPtr = callbackPtr->procPtr;
	TOP_CB(interp) = callbackPtr->nextPtr;
	result = procPtr(callbackPtr->data, interp, result);
	TCLNR_FREE(interp, callbackPtr);
    }
    return result;
}

................................................................................
                "invalid hidden command name \"%s\"", cmdName));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
                NULL);
	return TCL_ERROR;
    }
    cmdPtr = Tcl_GetHashValue(hPtr);


    /* Avoid the exception-handling brain damage when numLevels == 0 . */


    iPtr->numLevels++;
    Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);

    /*
     * Normal command resolution of objv[0] isn't going to find cmdPtr.
     * That's the whole point of **hidden** commands.  So tell the
     * Eval core machinery not to even try (and risk finding something wrong).
     */

    return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
}

static int
NRPostInvoke(
................................................................................
	kini("line");	kini("level");
#undef kini
    }
    for (i = 0; i < 6; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
	args[i] = val ? TclGetString(val) : NULL;
    }


    /* no "proc" -> use "lambda" */


    if (!args[2]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[2] = val ? TclGetString(val) : NULL;
    }
    k++;


    /* no "class" -> use "object" */


    if (!args[5]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[5] = val ? TclGetString(val) : NULL;
    }
    k++;
    for (i = 0; i < 2; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
................................................................................
     * at the proper time.
     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;


        /* The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled. */


        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        listPtr = Tcl_NewListObj(objc, objv);
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
................................................................................
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *





































































 * NRCoroInjectObjCmd --
 *
 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

................................................................................
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;

    TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
	    NULL, NULL, NULL);


    /* ensure that the command is looked up in the correct namespace */


    iPtr->lookupNsPtr = lookupNsPtr;
    Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
    iPtr->numLevels--;

    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);
    iPtr->execEnvPtr = corPtr->callerEEPtr;

    /*

static Tcl_NRPostProc	TEOV_RestoreVarFrame;
static Tcl_NRPostProc	TEOV_RunLeaveTraces;
static Tcl_NRPostProc	EvalObjvCore;
static Tcl_NRPostProc	Dispatch;

static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;

MODULE_SCOPE const TclStubs tclStubs;

/*
 * Magical counts for the number of arguments accepted by a coroutine command
 * after particular kinds of [yield].
 */
................................................................................

    /* Adding the bytecode assembler command */
    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    cmdPtr->compileProc = &TclCompileAssembleCmd;

    /* Coroutine monkeybusiness */
    Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
	    NRCoroInjectObjCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
            CoroTypeObjCmd, NULL, NULL);

    /* Export unsupported commands */
    nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
    if (nsPtr) {
	Tcl_Export(interp, nsPtr, "*", 1);
    }

................................................................................
	    /*
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}

	/*
         * An existing command conflicts. Try to delete it...
         */

	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * Be careful to preserve any existing import links so we can restore
	 * them down below. That way, you can redefine a command and its
	 * import status will remain intact.

	 */

	cmdPtr->refCount++;
	if (cmdPtr->importRefPtr) {
	    cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
	}

................................................................................
	}
	TclCleanupCommandMacro(cmdPtr);
	deleted = 1;
    }

    if (!isNew) {
	/*
	 * If the deletion callback recreated the command, just throw away the
	 * new command (if we try to delete it again, we could get stuck in an
	 * infinite loop).
	 */

	Tcl_Free(Tcl_GetHashValue(hPtr));
    }

    if (!deleted) {

	/*
	 * Command resolvers (per-interp, per-namespace) might have resolved
	 * to a command for the given namespace scope with this command not
	 * being registered with the namespace's command table. During BC
	 * compilation, the so-resolved command turns into a CmdName literal.
	 * Without invalidating a possible CmdName literal here explicitly,
	 * such literals keep being reused while pointing to overhauled
................................................................................
	     * isNew - No conflict with existing command.
	     * deleted - We've already deleted a conflicting command
	     */
	    break;
	}

	/*
         * An existing command conflicts. Try to delete it...
         */

	cmdPtr = Tcl_GetHashValue(hPtr);

	/*
	 * Command already exists; delete it. Be careful to preserve any
	 * existing import links so we can restore them down below. That way,
................................................................................
    /*
     * Lookup the Command to dispatch.
     */

    reresolve:
    assert(cmdPtr == NULL);
    if (preCmdPtr) {
	/*
         * Caller gave it to us.
         */

	if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
	    /*
             * So long as it exists, use it.
             */

	    cmdPtr = preCmdPtr;
	} else if (flags & TCL_EVAL_NORESOLVE) {
	    /*
	     * When it's been deleted, and we're told not to attempt resolving
	     * it ourselves, all we can do is raise an error.
	     */

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "attempt to invoke a deleted command"));
	    Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
	    return TCL_ERROR;
	}
    }
    if (cmdPtr == NULL) {
................................................................................
	if (!cmdPtr) {
	    return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
	}
    }

    if (enterTracesDone || iPtr->tracePtr
	    || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {

	Tcl_Obj *commandPtr = TclGetSourceFromFrame(
		flags & TCL_EVAL_SOURCE_IN_FRAME ?  iPtr->cmdFramePtr : NULL,
		objc, objv);


	Tcl_IncrRefCount(commandPtr);
	if (!enterTracesDone) {

	    int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
		    objc, objv);

	    /*
	     * Send any exception from enter traces back as an exception
	     * raised by the traced command.
	     * TODO: Is this a bug?  Letting an execution trace BREAK or
	     * CONTINUE or RETURN in the place of the traced command?  Would
	     * either converting all exceptions to TCL_ERROR, or just
	     * swallowing them be better?  (Swallowing them has the problem of
	     * permanently hiding program errors.)
	     */

	    if (code != TCL_OK) {
		Tcl_DecrRefCount(commandPtr);
		return code;
	    }

	    /*
	     * If the enter traces made the resolved cmdPtr unusable, go back
	     * and resolve again, but next time don't run enter traces again.

	     */

	    if (cmdPtr == NULL) {
		enterTracesDone = 1;
		Tcl_DecrRefCount(commandPtr);
		goto reresolve;
	    }
	}

	/*
	 * Schedule leave traces.  Raise the refCount on the resolved cmdPtr,
	 * so that when it passes to the leave traces we know it's still
	 * valid.
	 */

	cmdPtr->refCount++;
	TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
		    commandPtr, cmdPtr, objv);
    }

................................................................................
TclNRRunCallbacks(
    Tcl_Interp *interp,
    int result,
    struct NRE_callback *rootPtr)
				/* All callbacks down to rootPtr not inclusive
				 * are to be run. */
{
    while (TOP_CB(interp) != rootPtr) {
        NRE_callback *callbackPtr = TOP_CB(interp);
        Tcl_NRPostProc *procPtr = callbackPtr->procPtr;




	TOP_CB(interp) = callbackPtr->nextPtr;
	result = procPtr(callbackPtr->data, interp, result);
	TCLNR_FREE(interp, callbackPtr);
    }
    return result;
}

................................................................................
                "invalid hidden command name \"%s\"", cmdName));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
                NULL);
	return TCL_ERROR;
    }
    cmdPtr = Tcl_GetHashValue(hPtr);

    /*
     * Avoid the exception-handling brain damage when numLevels == 0
     */

    iPtr->numLevels++;
    Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);

    /*
     * Normal command resolution of objv[0] isn't going to find cmdPtr.
     * That's the whole point of **hidden** commands.  So tell the Eval core
     * machinery not to even try (and risk finding something wrong).
     */

    return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
}

static int
NRPostInvoke(
................................................................................
	kini("line");	kini("level");
#undef kini
    }
    for (i = 0; i < 6; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
	args[i] = val ? TclGetString(val) : NULL;
    }

    /*
     * no "proc" -> use "lambda"
     */

    if (!args[2]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[2] = val ? TclGetString(val) : NULL;
    }
    k++;

    /*
     * no "class" -> use "object"
     */

    if (!args[5]) {
	Tcl_DictObjGet(NULL, info, *k, &val);
	args[5] = val ? TclGetString(val) : NULL;
    }
    k++;
    for (i = 0; i < 2; i++) {
	Tcl_DictObjGet(NULL, info, *k++, &val);
................................................................................
     * at the proper time.
     */

    if (objc > 1) {
        Tcl_Obj *listPtr, *nsObjPtr;
        Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;

        /*
         * The tailcall data is in a Tcl list: the first element is the
         * namespace, the rest the command to be tailcalled.
         */

        nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
        listPtr = Tcl_NewListObj(objc, objv);
 	TclListObjSetElement(interp, listPtr, 0, nsObjPtr);

        iPtr->varFramePtr->tailcallPtr = listPtr;
    }
................................................................................
    TclListObjGetElements(NULL, listPtr, &objc, &objv);
    return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * CoroTypeObjCmd --
 *
 *      Implementation of [::tcl::unsupported::corotype] command.
 *
 *----------------------------------------------------------------------
 */

static int
CoroTypeObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Command *cmdPtr;
    CoroutineData *corPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "coroName");
	return TCL_ERROR;
    }

    /*
     * Look up the coroutine.
     */

    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
    if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "can only get coroutine type of a coroutine", -1));
        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
                TclGetString(objv[1]), NULL);
        return TCL_ERROR;
    }

    /*
     * An active coroutine is "active". Can't tell what it might do in the
     * future.
     */

    corPtr = cmdPtr->objClientData;
    if (!COR_IS_SUSPENDED(corPtr)) {
        Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
        return TCL_OK;
    }

    /*
     * Inactive coroutines are classified by the (effective) command used to
     * suspend them, which matters when you're injecting a probe.
     */

    switch (corPtr->nargs) {
    case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
        return TCL_OK;
    case COROUTINE_ARGUMENTS_ARBITRARY:
        Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
        return TCL_OK;
    default:
        Tcl_SetObjResult(interp, Tcl_NewStringObj(
                "unknown coroutine type", -1));
        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
        return TCL_ERROR;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * NRCoroInjectObjCmd --
 *
 *      Implementation of [::tcl::unsupported::inject] command.
 *
 *----------------------------------------------------------------------
 */

................................................................................
    corPtr->callerEEPtr = iPtr->execEnvPtr;
    RESTORE_CONTEXT(corPtr->running);
    iPtr->execEnvPtr = corPtr->eePtr;

    TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
	    NULL, NULL, NULL);

    /*
     * Ensure that the command is looked up in the correct namespace.
     */

    iPtr->lookupNsPtr = lookupNsPtr;
    Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0);
    iPtr->numLevels--;

    SAVE_CONTEXT(corPtr->running);
    RESTORE_CONTEXT(corPtr->caller);
    iPtr->execEnvPtr = corPtr->callerEEPtr;

    /*

	Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
    }
    if (len == TCL_AUTO_LENGTH) {
	Tcl_Panic("%s must be called with definite number of bytes to append",
		"TclAppendBytesToByteArray");
    }
    if (len == 0) {

	/* Append zero bytes is a no-op. */


	return;
    }

    irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
    if (irPtr == NULL) {
	if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) {
	    Tcl_Panic("attempt to append bytes to non-bytearray");

	Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
    }
    if (len == TCL_AUTO_LENGTH) {
	Tcl_Panic("%s must be called with definite number of bytes to append",
		"TclAppendBytesToByteArray");
    }
    if (len == 0) {
	/*
	 * Append zero bytes is a no-op.
	 */

	return;
    }

    irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
    if (irPtr == NULL) {
	if (TCL_ERROR == SetByteArrayFromAny(NULL, objPtr)) {
	    Tcl_Panic("attempt to append bytes to non-bytearray");

    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i=0 ; defineCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::define::");
	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }
    for (i=0 ; objdefCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }

................................................................................

    InitClassSystemRoots(interp, fPtr);

    /*
     * Basic method declarations for the core classes.
     */

    for (i=0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i=0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }

    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.
     */

    TclNewLiteralStringObj(namePtr, "new");
    Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
    fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */
................................................................................
	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }


  configNamespace:

    ((Namespace *)oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */

    if (fPtr->helpersNs != NULL) {
................................................................................

    /*
     * Squelch classes that this class has been mixed into.
     */

    if (clsPtr->mixinSubs.num > 0) {
	while (clsPtr->mixinSubs.num > 0) {

	    mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];


	    /* This condition also covers the case where mixinSubclassPtr ==
	     * clsPtr
	     */

	    if (!Deleted(mixinSubclassPtr->thisPtr)
		    && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			mixinSubclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch subclasses of this class.
     */

    if (clsPtr->subclasses.num > 0) {
	while (clsPtr->subclasses.num > 0) {
	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
		    && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			subclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (clsPtr->instances.num > 0) {
	while (clsPtr->instances.num > 0) {
	    instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];

	    /*
	     * This condition also covers the case where instancePtr == oPtr
	     */

	    if (!Deleted(instancePtr) && !IsRoot(instancePtr) &&
		    !(instancePtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
................................................................................
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    int i;

    if (Deleted(oPtr)) {
	/*
	 * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
	 * guard could be removed.
	 */

	return;
    }

    /*
     * One rule for the teardown routines is that if an object is in the
     * process of being deleted, nothing else may modify its bookeeping
     * records.  This is the flag that
     */

    oPtr->flags |= OBJECT_DELETED;


    /* Let the dominoes fall */


    if (oPtr->classPtr) {
	TclOODeleteDescendants(interp, oPtr);
    }

    /*
     * We do not run destructors on the core class objects when the
     * interpreter is being deleted; their incestuous nature causes problems
................................................................................
     * of it have gone. [Bug 2949397]
     */

    if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
	int result;

	Tcl_InterpState state;

	oPtr->flags |= DESTRUCTOR_CALLED;

	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
................................................................................
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }

    /*
     * Instruct everyone to no longer use any allocated fields of the object.
     * Also delete the command that refers to the object at this point (if
     * it still exists) because otherwise its pointer to the object
     * points into freed memory.
     */

    if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) {
	/*
	 * Something has already started the command deletion process. We can
	 * go ahead and clean up the the namespace,
	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command
................................................................................
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */

    /*
     * TODO: Should this be protected with a * !IsRoot() condition?
     */

    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
................................................................................
     */

    TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
	    objectPtr);
    TclPushTailcallPoint(interp);
    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

 
Object *
TclNewObjectInstanceCommon(
    Tcl_Interp *interp,
    Class *classPtr,
    const char *nameStr,
    const char *nsNameStr)
................................................................................
{
    Tcl_HashEntry *hPtr;
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    const char *simpleName = NULL;
    Namespace *nsPtr = NULL, *dummy;
    Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
    int isNew;

    if (nameStr) {
	TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);

	/*
	 * Disallow creation of an object over an existing command.
	 */

	hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "can't create object \"%s\": command already exists with"
		    " that name", nameStr));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
	    return NULL;
	}

	/*
	 * We could make a hash entry! Don't actually want to do that here so
	 * nuke it immediately because we'll create it properly soon.
	 */

	Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Create the object.
     */

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
................................................................................
	TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
    } else {
	oPtr->classPtr = NULL;
    }
    return oPtr;
}
 


static int
FinalizeAlloc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
................................................................................
	Tcl_Free(o2Ptr->mixins.list);
    }
    DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOOAddToInstances(o2Ptr, mixinPtr);
	}


	/* For the reference just created in DUPLICATE */


	AddRef(mixinPtr->thisPtr);
    }

    /*
     * Copy the object's filter list to the new object.
     */

................................................................................
     * kept object-local. The duplicate is never deleted at this point, nor is
     * it the root of the object system or in the midst of processing a filter
     * call.
     */

    o2Ptr->flags = oPtr->flags & ~(
	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);

    /*
     * Copy the object's metadata.
     */

    if (oPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value, duplicate;
................................................................................
	}
	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
		sizeof(Class *) * clsPtr->superclasses.num);
	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOOAddToSubclasses(cls2Ptr, superPtr);


	    /* For the new item in cls2Ptr->superclasses that memcpy just
	     * created
	     */

	    AddRef(superPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's filters.
	 */

................................................................................
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    Tcl_Free(clsPtr->mixins.list);
	}
	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);


	    /* For the copy just created in DUPLICATE */


	    AddRef(mixinPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's methods, constructor and destructor.
	 */

................................................................................
    int skip)
{
    CallContext *contextPtr = (CallContext *) context;
    int savedIndex = contextPtr->index;
    int savedSkip = contextPtr->skip;
    int result;

    if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */

................................................................................
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv,
    int skip)
{
    register CallContext *contextPtr = (CallContext *) context;

    if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */

    Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);

    /*
     * Create the subcommands in the oo::define and oo::objdefine spaces.
     */

    Tcl_DStringInit(&buffer);
    for (i = 0 ; defineCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::define::");
	Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }
    for (i = 0 ; objdefCmds[i].name ; i++) {
	TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
	Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
	Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
		objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
	Tcl_DStringFree(&buffer);
    }

................................................................................

    InitClassSystemRoots(interp, fPtr);

    /*
     * Basic method declarations for the core classes.
     */

    for (i = 0 ; objMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
    }
    for (i = 0 ; clsMethods[i].name ; i++) {
	TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
    }

    /*
     * Finish setting up the class of classes by marking the 'new' method as
     * private; classes, unlike general objects, must have explicit names. We
     * also need to create the constructor for classes.
     */

    TclNewLiteralStringObj(namePtr, "new");
    Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
	    namePtr /* keeps ref */, 0 /* private */, NULL, NULL);
    fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
	    (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);

    /*
     * Create non-object commands and plug ourselves into the Tcl [info]
     * ensemble.
     */
................................................................................
	 * have to get rid of the error message from Tcl_CreateNamespace,
	 * since that's something that should not be exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }


  configNamespace:

    ((Namespace *) oPtr->namespacePtr)->refCount++;

    /*
     * Make the namespace know about the helper commands. This grants access
     * to the [self] and [next] commands.
     */

    if (fPtr->helpersNs != NULL) {
................................................................................

    /*
     * Squelch classes that this class has been mixed into.
     */

    if (clsPtr->mixinSubs.num > 0) {
	while (clsPtr->mixinSubs.num > 0) {
	    mixinSubclassPtr =
		    clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];

	    /*
	     * This condition also covers the case where mixinSubclassPtr ==
	     * clsPtr
	     */

	    if (!Deleted(mixinSubclassPtr->thisPtr)
		    && !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			mixinSubclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch subclasses of this class.
     */

    if (clsPtr->subclasses.num > 0) {
	while (clsPtr->subclasses.num > 0) {
	    subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
	    if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
		    && !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp,
			subclassPtr->thisPtr->command);
	    }
	    TclOORemoveFromSubclasses(subclassPtr, clsPtr);
	}
................................................................................

    /*
     * Squelch instances of this class (includes objects we're mixed into).
     */

    if (clsPtr->instances.num > 0) {
	while (clsPtr->instances.num > 0) {
	    instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];

	    /*
	     * This condition also covers the case where instancePtr == oPtr
	     */

	    if (!Deleted(instancePtr) && !IsRoot(instancePtr) &&
		    !(instancePtr->flags & DONT_DELETE)) {
		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
................................................................................
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    int i;

    if (Deleted(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
	 * this guard could be removed.
	 */

	return;
    }

    /*
     * One rule for the teardown routines is that if an object is in the
     * process of being deleted, nothing else may modify its bookeeping
     * records.  This is the flag that
     */

    oPtr->flags |= OBJECT_DELETED;

    /*
     * Let the dominoes fall!
     */

    if (oPtr->classPtr) {
	TclOODeleteDescendants(interp, oPtr);
    }

    /*
     * We do not run destructors on the core class objects when the
     * interpreter is being deleted; their incestuous nature causes problems
................................................................................
     * of it have gone. [Bug 2949397]
     */

    if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
	int result;

	Tcl_InterpState state;

	oPtr->flags |= DESTRUCTOR_CALLED;

	if (contextPtr != NULL) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
................................................................................
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }

    /*
     * Instruct everyone to no longer use any allocated fields of the object.
     * Also delete the command that refers to the object at this point (if it
     * still exists) because otherwise its pointer to the object points into
     * freed memory.
     */

    if (((Command *) oPtr->command)->flags && CMD_IS_DELETED) {
	/*
	 * Something has already started the command deletion process. We can
	 * go ahead and clean up the the namespace,
	 */
    } else {
	/*
	 * The namespace must have been deleted directly.  Delete the command
................................................................................
    }

    /*
     * Splice the object out of its context. After this, we must *not* call
     * methods on the object.
     */


    /* TODO: Should this be protected with a !IsRoot() condition? */


    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

    if (oPtr->mixins.num > 0) {
	FOREACH(mixinPtr, oPtr->mixins) {
	    TclOORemoveFromInstances(oPtr, mixinPtr);
	    TclOODecrRefCount(mixinPtr->thisPtr);
	}
................................................................................
     */

    TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
	    objectPtr);
    TclPushTailcallPoint(interp);
    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

 
Object *
TclNewObjectInstanceCommon(
    Tcl_Interp *interp,
    Class *classPtr,
    const char *nameStr,
    const char *nsNameStr)
................................................................................
{
    Tcl_HashEntry *hPtr;
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    const char *simpleName = NULL;
    Namespace *nsPtr = NULL, *dummy;
    Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);


    if (nameStr) {
	TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
		TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);

	/*
	 * Disallow creation of an object over an existing command.
	 */

	hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simpleName);
	if (hPtr) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "can't create object \"%s\": command already exists with"
		    " that name", nameStr));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
	    return NULL;
	}







    }

    /*
     * Create the object.
     */

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
................................................................................
	TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
    } else {
	oPtr->classPtr = NULL;
    }
    return oPtr;
}
 


static int
FinalizeAlloc(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
................................................................................
	Tcl_Free(o2Ptr->mixins.list);
    }
    DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
    FOREACH(mixinPtr, o2Ptr->mixins) {
	if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
	    TclOOAddToInstances(o2Ptr, mixinPtr);
	}

	/*
	 * For the reference just created in DUPLICATE.
	 */

	AddRef(mixinPtr->thisPtr);
    }

    /*
     * Copy the object's filter list to the new object.
     */

................................................................................
     * kept object-local. The duplicate is never deleted at this point, nor is
     * it the root of the object system or in the midst of processing a filter
     * call.
     */

    o2Ptr->flags = oPtr->flags & ~(
	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);

    /*
     * Copy the object's metadata.
     */

    if (oPtr->metadataPtr != NULL) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	ClientData value, duplicate;
................................................................................
	}
	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
		sizeof(Class *) * clsPtr->superclasses.num);
	cls2Ptr->superclasses.num = clsPtr->superclasses.num;
	FOREACH(superPtr, cls2Ptr->superclasses) {
	    TclOOAddToSubclasses(cls2Ptr, superPtr);

	    /*
	     * For the new item in cls2Ptr->superclasses that memcpy just
	     * created.
	     */

	    AddRef(superPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's filters.
	 */

................................................................................
		TclOODecrRefCount(mixinPtr->thisPtr);
	    }
	    Tcl_Free(clsPtr->mixins.list);
	}
	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
	FOREACH(mixinPtr, cls2Ptr->mixins) {
	    TclOOAddToMixinSubs(cls2Ptr, mixinPtr);

	    /*
	     * For the copy just created in DUPLICATE.
	     */

	    AddRef(mixinPtr->thisPtr);
	}

	/*
	 * Duplicate the source class's methods, constructor and destructor.
	 */

................................................................................
    int skip)
{
    CallContext *contextPtr = (CallContext *) context;
    int savedIndex = contextPtr->index;
    int savedSkip = contextPtr->skip;
    int result;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */

................................................................................
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv,
    int skip)
{
    register CallContext *contextPtr = (CallContext *) context;

    if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message unless the
	 * interpreter is being torn down, in which case we might be getting
	 * here because of methods/destructors doing a [next] (or equivalent)
	 * unexpectedly.
	 */

     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	int i;

	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
	 * Ensure that the method name itself is part of the arguments when
	 * we're doing unknown processing.
	 */
................................................................................
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
    int i;

    for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
    }
    return result;
}
 
/*
 * ----------------------------------------------------------------------
................................................................................
    } else {
	Tcl_Free((void *)strings);
	*stringsPtr = NULL;
    }
    return i;
}


/* Comparator for SortMethodNames */


static int
CmpStr(
    const void *ptr1,
    const void *ptr2)
{
    const char **strPtr1 = (const char **) ptr1;
    const char **strPtr2 = (const char **) ptr2;
................................................................................
    }

    /*
     * First test whether the method is already in the call chain. Skip over
     * any leading filters.
     */

    for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) {
	if (callPtr->chain[i].mPtr == mPtr &&
		callPtr->chain[i].isFilter == (doneFilters != NULL)) {
	    /*
	     * Call chain semantics states that methods come as *late* in the
	     * call chain as possible. This is done by copying down the
	     * following methods. Note that this does not change the number of
	     * method invocations in the call chain; it just rearranges them.
	     */

	    Class *declCls = callPtr->chain[i].filterDeclarer;

	    for (; i+1<callPtr->numChain ; i++) {
		callPtr->chain[i] = callPtr->chain[i+1];
	    }
	    callPtr->chain[i].mPtr = mPtr;
	    callPtr->chain[i].isFilter = (doneFilters != NULL);
	    callPtr->chain[i].filterDeclarer = declCls;
	    return;
	}
    }
................................................................................
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i=0 ; i<callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] =
	    miPtr->isFilter ? filterLiteral :
	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
		    methodLiteral;

     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	int i;

	for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
	 * Ensure that the method name itself is part of the arguments when
	 * we're doing unknown processing.
	 */
................................................................................
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
    int i;

    for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
    }
    return result;
}
 
/*
 * ----------------------------------------------------------------------
................................................................................
    } else {
	Tcl_Free((void *)strings);
	*stringsPtr = NULL;
    }
    return i;
}

/*
 * Comparator for SortMethodNames
 */

static int
CmpStr(
    const void *ptr1,
    const void *ptr2)
{
    const char **strPtr1 = (const char **) ptr1;
    const char **strPtr2 = (const char **) ptr2;
................................................................................
    }

    /*
     * First test whether the method is already in the call chain. Skip over
     * any leading filters.
     */

    for (i = cbPtr->filterLength ; i < callPtr->numChain ; i++) {
	if (callPtr->chain[i].mPtr == mPtr &&
		callPtr->chain[i].isFilter == (doneFilters != NULL)) {
	    /*
	     * Call chain semantics states that methods come as *late* in the
	     * call chain as possible. This is done by copying down the
	     * following methods. Note that this does not change the number of
	     * method invocations in the call chain; it just rearranges them.
	     */

	    Class *declCls = callPtr->chain[i].filterDeclarer;

	    for (; i + 1 < callPtr->numChain ; i++) {
		callPtr->chain[i] = callPtr->chain[i + 1];
	    }
	    callPtr->chain[i].mPtr = mPtr;
	    callPtr->chain[i].isFilter = (doneFilters != NULL);
	    callPtr->chain[i].filterDeclarer = declCls;
	    return;
	}
    }
................................................................................
     * special because it's a filter method). The second word is the name of
     * the method in question (which differs for "unknown" and "filter" types)
     * and the third word is the full name of the class that declares the
     * method (or "object" if it is declared on the instance).
     */

    objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
    for (i = 0 ; i < callPtr->numChain ; i++) {
	struct MInvoke *miPtr = &callPtr->chain[i];

	descObjs[0] =
	    miPtr->isFilter ? filterLiteral :
	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
		    methodLiteral;

	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
		    getter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
		    setter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
		    resolver, NULL, NULL}}







/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (oPtr->filters.num == 0) {
	    filtersList = Tcl_Alloc(size);
	} else {
	    filtersList = Tcl_Realloc(oPtr->filters.list, size);
	}
	for (i=0 ; i<numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	oPtr->filters.list = filtersList;
	oPtr->filters.num = numFilters;
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (classPtr->filters.num == 0) {
	    filtersList = Tcl_Alloc(size);
	} else {
	    filtersList = Tcl_Realloc(classPtr->filters.list, size);
	}
	for (i=0 ; i<numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	classPtr->filters.list = filtersList;
	classPtr->filters.num = numFilters;
    }

................................................................................
	    oPtr->flags &= ~USE_CLASS_CACHE;
	}
	oPtr->mixins.num = numMixins;
	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, oPtr->mixins) {
	    if (mixinPtr != oPtr->selfCls) {
		TclOOAddToInstances(oPtr, mixinPtr);


		/* For the new copy created by memcpy */


		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}
 
................................................................................
	} else {
	    classPtr->mixins.list = Tcl_Alloc(sizeof(Class *) * numMixins);
	}
	classPtr->mixins.num = numMixins;
	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, classPtr->mixins) {
	    TclOOAddToMixinSubs(classPtr, mixinPtr);


	    /* For the new copy created by memcpy */


	    AddRef(mixinPtr->thisPtr);
	}
    }
    BumpGlobalEpoch(interp, classPtr);
}
 
/*
................................................................................
    }

    if (matchedStr != NULL) {
	/*
	 * Got one match, and only one match!
	 */


	Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
	int result;

	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
	Tcl_IncrRefCount(newObjv[0]);
	if (objc > 2) {
	    memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
	}
	result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
	Tcl_DecrRefCount(newObjv[0]);
	TclStackFree(interp, newObjv);
	return result;
    }

  noMatch:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
................................................................................
     * comments above for why these contortions are necessary.
     */

    objPtr = Tcl_NewObj();
    obj2Ptr = Tcl_NewObj();
    cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
    if (cmd == NULL) {

	/* punt this case! */


	Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
    } else {
	Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
    }
    Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
    /* TODO: overflow? */
    Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset);
    Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);

    result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE);
    if (isRoot) {
	TclResetRewriteEnsemble(interp, 1);
    }
    Tcl_DecrRefCount(objPtr);

    return result;
}
................................................................................
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i=1 ; i<objc ; i++) {
	/*
	 * Delete the method structure from the appropriate hash table.
	 */

	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
		objv[i], NULL) != TCL_OK) {
	    return TCL_ERROR;
................................................................................
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i=1 ; i<objc ; i++) {
	/*
	 * Exporting is done by adding the PUBLIC_METHOD flag to the method
	 * record. If there is no such method in this object or class (i.e.
	 * the method comes from something inherited from or that we're an
	 * instance of) then we put in a blank record with that flag; such
	 * records are skipped over by the call chain engine *except* for
	 * their flags member.
................................................................................
    }
    if (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }

    /*
     * Create the method structure.
     */

    prefixObj = Tcl_NewListObj(objc-2, objv+2);
    if (isInstanceForward) {
	mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
		prefixObj);
    } else {
	mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
		objv[1], prefixObj);
    }
................................................................................
	    isPublic = 0;
	    break;
	}
    } else {
	if (IsPrivateDefine(interp)) {
	    isPublic = TRUE_PRIVATE_METHOD;
	} else {
	    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
		    ? PUBLIC_METHOD : 0;
	}
    }

    /*
     * Create the method by using the right back-end API.
     */
................................................................................
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i=1 ; i<objc ; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
	 * method record. If there is no such method in this object or class
	 * (i.e. the method comes from something inherited from or that we're
	 * an instance of) then we put in a blank record without that flag;
	 * such records are skipped over by the call chain engine *except* for
	 * their flags member.
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int superc, i, j;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	    superclasses[0] = oPtr->fPtr->classCls;
	} else {
	    superclasses[0] = oPtr->fPtr->objectCls;
	}
	superc = 1;
	AddRef(superclasses[0]->thisPtr);
    } else {
	for (i=0 ; i<superc ; i++) {
	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
		    "only a class can be a superclass");
	    if (superclasses[i] == NULL) {
		i--;
		goto failedAfterAlloc;
	    }
	    for (j=0 ; j<i ; j++) {
		if (superclasses[j] == superclasses[i]) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "class should only be a direct superclass once",
			    -1));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
		    goto failedAfterAlloc;
		}
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i=0 ; i<varc ; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc;
    Tcl_Obj **mixinv;
    Class **mixins;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
    if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i=0 ; i<mixinc ; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}
    }
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc, i;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i=0 ; i<varc ; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);

	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
		    getter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
		    setter, NULL, NULL},				\
	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \
		    resolver, NULL, NULL}}

/*
 * A [string match] pattern used to determine if a method should be exported.
 */

#define PUBLIC_PATTERN		"[a-z]*"

/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (oPtr->filters.num == 0) {
	    filtersList = Tcl_Alloc(size);
	} else {
	    filtersList = Tcl_Realloc(oPtr->filters.list, size);
	}
	for (i = 0 ; i < numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	oPtr->filters.list = filtersList;
	oPtr->filters.num = numFilters;
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
................................................................................
	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */

	if (classPtr->filters.num == 0) {
	    filtersList = Tcl_Alloc(size);
	} else {
	    filtersList = Tcl_Realloc(classPtr->filters.list, size);
	}
	for (i = 0 ; i < numFilters ; i++) {
	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	classPtr->filters.list = filtersList;
	classPtr->filters.num = numFilters;
    }

................................................................................
	    oPtr->flags &= ~USE_CLASS_CACHE;
	}
	oPtr->mixins.num = numMixins;
	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, oPtr->mixins) {
	    if (mixinPtr != oPtr->selfCls) {
		TclOOAddToInstances(oPtr, mixinPtr);

		/*
		 * For the new copy created by memcpy().
		 */

		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
}
 
................................................................................
	} else {
	    classPtr->mixins.list = Tcl_Alloc(sizeof(Class *) * numMixins);
	}
	classPtr->mixins.num = numMixins;
	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
	FOREACH(mixinPtr, classPtr->mixins) {
	    TclOOAddToMixinSubs(classPtr, mixinPtr);

	    /*
	     * For the new copy created by memcpy.
	     */

	    AddRef(mixinPtr->thisPtr);
	}
    }
    BumpGlobalEpoch(interp, classPtr);
}
 
/*
................................................................................
    }

    if (matchedStr != NULL) {
	/*
	 * Got one match, and only one match!
	 */

	Tcl_Obj **newObjv =
		TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
	int result;

	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
	Tcl_IncrRefCount(newObjv[0]);
	if (objc > 2) {
	    memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
	}
	result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
	Tcl_DecrRefCount(newObjv[0]);
	TclStackFree(interp, newObjv);
	return result;
    }

  noMatch:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
................................................................................
     * comments above for why these contortions are necessary.
     */

    objPtr = Tcl_NewObj();
    obj2Ptr = Tcl_NewObj();
    cmd = FindCommand(interp, objv[cmdIndex], nsPtr);
    if (cmd == NULL) {
	/*
	 * Punt this case!
	 */

	Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
    } else {
	Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
    }
    Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
    /* TODO: overflow? */
    Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset);
    Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);

    result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE);
    if (isRoot) {
	TclResetRewriteEnsemble(interp, 1);
    }
    Tcl_DecrRefCount(objPtr);

    return result;
}
................................................................................
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Delete the method structure from the appropriate hash table.
	 */

	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
		objv[i], NULL) != TCL_OK) {
	    return TCL_ERROR;
................................................................................
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Exporting is done by adding the PUBLIC_METHOD flag to the method
	 * record. If there is no such method in this object or class (i.e.
	 * the method comes from something inherited from or that we're an
	 * instance of) then we put in a blank record with that flag; such
	 * records are skipped over by the call chain engine *except* for
	 * their flags member.
................................................................................
    }
    if (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;
    }

    /*
     * Create the method structure.
     */

    prefixObj = Tcl_NewListObj(objc - 2, objv + 2);
    if (isInstanceForward) {
	mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
		prefixObj);
    } else {
	mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
		objv[1], prefixObj);
    }
................................................................................
	    isPublic = 0;
	    break;
	}
    } else {
	if (IsPrivateDefine(interp)) {
	    isPublic = TRUE_PRIVATE_METHOD;
	} else {
	    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
		    ? PUBLIC_METHOD : 0;
	}
    }

    /*
     * Create the method by using the right back-end API.
     */
................................................................................
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
	 * method record. If there is no such method in this object or class
	 * (i.e. the method comes from something inherited from or that we're
	 * an instance of) then we put in a blank record without that flag;
	 * such records are skipped over by the call chain engine *except* for
	 * their flags member.
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc, i;
    Tcl_Obj **mixinv;
    Class **mixins;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
    } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    i--;
	    goto freeAndError;
	}
	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int superc, i, j;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"superclassList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	    superclasses[0] = oPtr->fPtr->classCls;
	} else {
	    superclasses[0] = oPtr->fPtr->objectCls;
	}
	superc = 1;
	AddRef(superclasses[0]->thisPtr);
    } else {
	for (i = 0; i < superc; i++) {
	    superclasses[i] = GetClassInOuterContext(interp, superv[i],
		    "only a class can be a superclass");
	    if (superclasses[i] == NULL) {
		i--;
		goto failedAfterAlloc;
	    }
	    for (j = 0; j < i; j++) {
		if (superclasses[j] == superclasses[i]) {
		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
			    "class should only be a direct superclass once",
			    -1));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
		    goto failedAfterAlloc;
		}
................................................................................
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
................................................................................
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i = 0; i < varc; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int mixinc;
    Tcl_Obj **mixinv;
    Class **mixins;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"mixinList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
................................................................................
    if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
	    &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (mixins[i] == NULL) {
	    TclStackFree(interp, mixins);
	    return TCL_ERROR;
	}
    }
................................................................................
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc, i;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"variableList");
	return TCL_ERROR;
    } else if (oPtr == NULL) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    for (i = 0; i < varc; i++) {
	const char *varName = TclGetString(varv[i]);

	if (strstr(varName, "::") != NULL) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);

    int id = PTR2INT(clientData);
    const char *listArgv[4];
    char *cmd;
    char string[TCL_INTEGER_SPACE];

    Tcl_MutexLock(&asyncTestMutex);
    for (asyncPtr = firstHandler; asyncPtr != NULL;
         asyncPtr = asyncPtr->nextPtr) {
        if (asyncPtr->id == id) break;


    }
    Tcl_MutexUnlock(&asyncTestMutex);

    if (!asyncPtr) {
        /* Woops - this one was deleted between the AsyncMark and now */
        return TCL_OK;
    }

    int id = PTR2INT(clientData);
    const char *listArgv[4];
    char *cmd;
    char string[TCL_INTEGER_SPACE];

    Tcl_MutexLock(&asyncTestMutex);
    for (asyncPtr = firstHandler; asyncPtr != NULL;
            asyncPtr = asyncPtr->nextPtr) {
        if (asyncPtr->id == id) {
            break;
        }
    }
    Tcl_MutexUnlock(&asyncTestMutex);

    if (!asyncPtr) {
        /* Woops - this one was deleted between the AsyncMark and now */
        return TCL_OK;
    }

    memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
    timerHandlerPtr->proc = proc;
    timerHandlerPtr->clientData = clientData;
    tsdPtr->lastTimerId++;
    timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);

    /*
     * Add the event to the queue in the correct position
     * (ordered by event firing time).
     */

    for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
	    prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
	if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
	    break;
	}
................................................................................
    Interp *iPtr = (Interp *) interp;

    Tcl_Time endTime, now;
    Tcl_WideInt diff;

    Tcl_GetTime(&now);
    endTime = now;
    endTime.sec += (long)(ms/1000);
    endTime.usec += ((int)(ms%1000))*1000;
    if (endTime.usec >= 1000000) {
	endTime.sec++;
	endTime.usec -= 1000000;
    }

    do {
	if (Tcl_AsyncReady()) {
................................................................................
	}
	if (iPtr->limit.timeEvent == NULL
		|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
	    diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
	    if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
		diff = 1;
	    }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);
		if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
		    break;
		}
	    } else {
		break;
	    }
	} else {
	    diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);

    memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
    timerHandlerPtr->proc = proc;
    timerHandlerPtr->clientData = clientData;
    tsdPtr->lastTimerId++;
    timerHandlerPtr->token = (Tcl_TimerToken) INT2PTR(tsdPtr->lastTimerId);

    /*
     * Add the event to the queue in the correct position (ordered by event
     * firing time).
     */

    for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
	    prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
	if (TCL_TIME_BEFORE(timerHandlerPtr->time, tPtr2->time)) {
	    break;
	}
................................................................................
    Interp *iPtr = (Interp *) interp;

    Tcl_Time endTime, now;
    Tcl_WideInt diff;

    Tcl_GetTime(&now);
    endTime = now;
    endTime.sec += (long)(ms / 1000);
    endTime.usec += ((int)(ms % 1000)) * 1000;
    if (endTime.usec >= 1000000) {
	endTime.sec++;
	endTime.usec -= 1000000;
    }

    do {
	if (Tcl_AsyncReady()) {
................................................................................
	}
	if (iPtr->limit.timeEvent == NULL
		|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
	    diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
            if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
                diff = 1;
            }
	    if (diff > 0) {
		Tcl_Sleep((long) diff);
                if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
                    break;
                }
	    } else {
                break;
            }
	} else {
	    diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
	    if (diff > TCL_TIME_MAXIMUM_SLICE) {
		diff = TCL_TIME_MAXIMUM_SLICE;
	    }
	    if (diff > 0) {
		Tcl_Sleep((int) diff);

    ::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
    ::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
    ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
    ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
    ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
    ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988}"
}

    ::msgcat::mcset ja DATE_FORMAT "%Y/%m/%d"
    ::msgcat::mcset ja TIME_FORMAT "%k:%M:%S"
    ::msgcat::mcset ja TIME_FORMAT_12 "%P %I:%M:%S"
    ::msgcat::mcset ja DATE_TIME_FORMAT "%Y/%m/%d %k:%M:%S %z"
    ::msgcat::mcset ja LOCALE_DATE_FORMAT "%EY年%m月%d日"
    ::msgcat::mcset ja LOCALE_TIME_FORMAT "%H時%M分%S秒"
    ::msgcat::mcset ja LOCALE_DATE_TIME_FORMAT "%EY年%m月%d日 (%a) %H時%M分%S秒 %z"
    ::msgcat::mcset ja LOCALE_ERAS "{-9223372036854775808 西暦 0} {-3061011600 明治 1867} {-1812186000 大正 1911} {-1357635600 昭和 1925} {600220800 平成 1988} {1556668800 令和 2018}"
}

} -result {0 10 1 Hejsan}

test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
    unset -nocomplain a
} -body {
    run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}













} ;# End of noComp loop

test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
    set ::x global
    namespace eval ns {
	variable x namespace

} -result {0 10 1 Hejsan}

test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
    unset -nocomplain a
} -body {
    run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}

test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -setup {
    unset -nocomplain ::CRLF
    set ::CRLF "\r\n"
} -body {
    # Force variant that turned up in Bug 2c154a40be as that's externally
    # noticeable in an important downstream project.
    run {scan [list {*}$::CRLF]x %c%c%c}
} -cleanup {
    unset -nocomplain ::CRLF
} -result {120 {} {}}


} ;# End of noComp loop

test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
    set ::x global
    namespace eval ns {
	variable x namespace

		}
	    }
	    return $retval
	}
    }
    -body {
	set trouble {}
	foreach {date jdate} [list \
	    1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \
	    1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \
	    1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \
	    1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \
	    1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \
	    1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \
	    1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \
	    1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \


	] {
	    set status [catch {
		set secs [clock scan $date \
			      -timezone +0900 \
			      -locale ja_JP \
			      -format %Y-%m-%d]
		set jda [clock format $secs \
			     -timezone +0900 \

		}
	    }
	    return $retval
	}
    }
    -body {
	set trouble {}
	foreach {date jdate} {
	    1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5
	    1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5
	    1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5
	    1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5
	    1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5
	    1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5
	    1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5
	    1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5
	    2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5
	    2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5
	} {
	    set status [catch {
		set secs [clock scan $date \
			      -timezone +0900 \
			      -locale ja_JP \
			      -format %Y-%m-%d]
		set jda [clock format $secs \
			     -timezone +0900 \

    }
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}











































































 
# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End:

    }
    slave eval demo
    set result [slave eval {set ::result}]

    interp delete slave
    set result
} -result {inject-executed}

test coroutine-9.1 {coro type} {
    coroutine demo eval {
	yield
	yield "PHASE 1"
	yieldto string cat "PHASE 2"
	::tcl::unsupported::corotype [info coroutine]
    }
    list [demo] [::tcl::unsupported::corotype demo] \
	[demo] [::tcl::unsupported::corotype demo] [demo]
} {{PHASE 1} yield {PHASE 2} yieldto active}
test coroutine-9.2 {coro type} -setup {
    catch {rename nosuchcommand ""}
} -returnCodes error -body {
    ::tcl::unsupported::corotype nosuchcommand
} -result {can only get coroutine type of a coroutine}
test coroutine-9.3 {coro type} -returnCodes error -body {
    proc notacoroutine {} {}
    ::tcl::unsupported::corotype notacoroutine
} -returnCodes error -cleanup {
    rename notacoroutine {}
} -result {can only get coroutine type of a coroutine}

test coroutine-10.1 {coroutine general introspection} -setup {
    set i [interp create]
} -body {
    $i eval {
	# Make the introspection code
	namespace path tcl::unsupported
	proc probe {type var} {
	    upvar 1 $var v
	    set f [info frame]
	    incr f -1
	    set result [list $v [dict get [info frame $f] proc]]
	    if {$type eq "yield"} {
		tailcall yield $result
	    } else {
		tailcall yieldto string cat $result
	    }
	}
	proc pokecoro {c var} {
	    inject $c probe [corotype $c] $var
	    $c
	}

	# Coroutine implementations
	proc cbody1 {} {
	    set val [info coroutine]
	    set accum {}
	    while {[set val [yield $val]] ne ""} {
		lappend accum $val
		set val ok
	    }
	    return $accum
	}
	proc cbody2 {} {
	    set val [info coroutine]
	    set accum {}
	    while {[llength [set val [yieldto string cat $val]]]} {
		lappend accum {*}$val
		set val ok
	    }
	    return $accum
	}

	# Make the coroutines
	coroutine c1 cbody1
	coroutine c2 cbody2
	list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
	    [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
	    [c1] [c2]
    }
} -cleanup {
    interp delete $i
} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}}
 
# cleanup
unset lambda
::tcltest::cleanupTests

return

# Local Variables:
# mode: tcl
# End:

testConstraint testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]

foreach i {int real bool string} {
    unset -nocomplain $i
}










 
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list $int $real $bool $string $wide

testConstraint testlink [llength [info commands testlink]]
testConstraint testlinkarray [llength [info commands testlinkarray]]

foreach i {int real bool string} {
    unset -nocomplain $i
}
 
test link-0.1 {leak test} {testlink} {
    interp create i
    load {} Tcltest i
    i eval {
	testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
	namespace delete ::
    }
    interp delete i
} {}
 
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
    testlink delete
} -body {
    testlink set 43 1.23 4 - 12341234 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234
    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
    list $int $real $bool $string $wide

    const WCHAR *linkDirPath,	/* The junction to read */
    REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
    DWORD desiredAccess)
{
    HANDLE hFile;
    DWORD returnedLength;

    hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING,

	    FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile == INVALID_HANDLE_VALUE) {
	/*
	 * Error creating directory.
	 */

................................................................................
	OutputDebugStringW(msgString);
    } else {
	MessageBeep(MB_ICONEXCLAMATION);
	MessageBoxW(NULL, msgString, L"Fatal Error",
		MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current
 *	application.
................................................................................
    Tcl_DStringInit(bufferPtr);

    wDomain = NULL;
    domain = Tcl_UtfFindFirst(name, '@');
    if (domain == NULL) {
	const char *ptr;


	/* no domain - firstly check it's the current user */


	if ( (ptr = TclpGetUserName(&ds)) != NULL
	  && strcasecmp(name, ptr) == 0
	) {

	    /* try safest and fastest way to get current user home */


	    ptr = TclGetEnv("HOME", &ds);
	    if (ptr != NULL) {
		Tcl_JoinPath(1, &ptr, bufferPtr);
		rc = 1;
		result = Tcl_DStringValue(bufferPtr);
	    }
	}
................................................................................
	nameLen = domain - name;
    }
    if (rc == 0) {
	Tcl_DStringInit(&ds);
	wName = TclUtfToWCharDString(name, nameLen, &ds);
	while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
	    /*
	     * user does not exists - if domain was not specified,
	     * try again using current domain.
	     */

	    rc = 1;
	    if (domain != NULL) break;




	    /* get current domain */


	    rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
	    if (rc != 0) break;


	    domain = INT2PTR(-1); /* repeat once */
	}
	if (rc == 0) {
	    DWORD i, size = MAX_PATH;

	    wHomeDir = uiPtr->usri1_home_dir;
	    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
		size = lstrlenW(wHomeDir);
		TclWCharToUtfDString(wHomeDir, size, bufferPtr);
	    } else {
		/*
		 * User exists but has no home dir. Return
		 * "{GetProfilesDirectory}/<user>".
		 */

		GetProfilesDirectoryW(buf, &size);
		TclWCharToUtfDString(buf, size-1, bufferPtr);
		Tcl_DStringAppend(bufferPtr, "/", 1);
		Tcl_DStringAppend(bufferPtr, name, nameLen);
	    }
	    result = Tcl_DStringValue(bufferPtr);


	    /* be sure we return normalized path */


	    for (i = 0; i < size; ++i){
		if (result[i] == '\\') result[i] = '/';


	    }
	    NetApiBufferFree((void *) uiPtr);
	}
	Tcl_DStringFree(&ds);
    }
    if (wDomain != NULL) {
	NetApiBufferFree((void *) wDomain);
................................................................................

	return 0;
    }

    /*
     * If it's not a directory (assume file), do several fast checks:
     */

    if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*
	 * If the attributes say this is not writable at all.  The file is a
	 * regular file (i.e., not a directory), then the file is not
	 * writable, full stop.	 For directories, the read-only bit is
	 * (mostly) ignored by Windows, so we can't ascertain anything about
	 * directory access from the attrib data.  However, if we have the
	 * advanced 'getFileSecurityProc', then more robust ACL checks
	 * will be done below.
	 */

	if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}


	/* If doesn't have the correct extension, it can't be executable */


	if ((mode & X_OK) && !NativeIsExec(nativePath)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}


	/* Special case for read/write/executable check on file */


	if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
	    DWORD mask = 0;
	    HANDLE hFile;


	    if (mode & R_OK) { mask |= GENERIC_READ;  }


	    if (mode & W_OK) { mask |= GENERIC_WRITE; }


	    if (mode & X_OK) { mask |= GENERIC_EXECUTE; }


	    hFile = CreateFile(nativePath, mask,
		FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
		OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
	    if (hFile != INVALID_HANDLE_VALUE) {
		CloseHandle(hFile);
		return 0;
	    }


	    /* fast exit if access was denied */


	    if (GetLastError() == ERROR_ACCESS_DENIED) {
		Tcl_SetErrno(EACCES);
		return -1;
	    }
	}


	/* We cannnot verify the access fast, check it below using security info. */


    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
     * The code below is remarkably complex for such a simple thing as finding
     * what permissions the OS has set for a file.
................................................................................
    /*
     * If we can use 'createFile' on this, then we can use the resulting
     * fileHandle to read more information (nlink, ino) than we can get from
     * other attributes reading APIs. If not, then we try to fall back on the
     * 'getFileAttributesExProc', and if that isn't available, then on even
     * simpler routines.
     *
     * Special consideration must be given to Windows hardcoded names
     * like CON, NULL, COM1, LPT1 etc. For these, we still need to
     * do the CreateFile as some may not exist (e.g. there is no CON
     * in wish by default). However the subsequent GetFileInformationByHandle
     * will fail. We do a WinIsReserved to see if it is one of the special
     * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION
     * structure.
     */

    fileHandle = CreateFile(nativePath, GENERIC_READ,
	    FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);

................................................................................
	if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
            fileType = GetFileType(fileHandle);
            CloseHandle(fileHandle);
            if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
                Tcl_SetErrno(ENOENT);
                return -1;
            }


            /* Mock up the expected structure */


            memset(&data, 0, sizeof(data));
            statPtr->st_atime = 0;
            statPtr->st_mtime = 0;
            statPtr->st_ctime = 0;
        } else {
            CloseHandle(fileHandle);
            statPtr->st_atime = ToCTime(data.ftLastAccessTime);
................................................................................

    if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	return NULL;
    }

    if (clientData != NULL) {
	if (wcscmp((const WCHAR*)clientData, buffer) == 0) {
	    return clientData;
	}
    }

    return TclNativeDupInternalRep(buffer);
}
 
................................................................................
			    }
			}
			Tcl_DStringAppend(&dsNorm,
				(const char *)nativePath,
				(int)(sizeof(WCHAR) * len));
			lastValidPathEnd = currentPathEndPosition;
		    } else if (nextCheckpoint == 0) {

			/* Path starts with a drive designation
			 * that's not actually on the system.
			 * We still must normalize up past the
			 * first separator.  [Bug 3603434] */


			currentPathEndPosition++;
		    }
		}
		Tcl_DStringFree(&ds);
		break;
	    }

................................................................................
	    /*
	     * File 'nativePath' does exist if we get here. We now want to
	     * check if it is a symlink and otherwise continue with the
	     * rest of the path.
	     */

	    /*
	     * Check for symlinks, except at last component of path (we
	     * don't follow final symlinks). Also a drive (C:/) for
	     * example, may sometimes have the reparse flag set for some
	     * reason I don't understand. We therefore don't perform this
	     * check for drives.
	     */

	    if (cur != 0 && !isDrive &&
		    data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
		Tcl_Obj *to = WinReadLinkDirectory(nativePath);

		if (to != NULL) {
		    /*
		     * Read the reparse point ok. Now, reparse points need
		     * not be normalized, otherwise we could use:
		     *
		     * Tcl_GetStringFromObj(to, &pathLen);
		     * nextCheckpoint = pathLen;
		     *
		     * So, instead we have to start from the beginning.
		     */

................................................................................
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    }

#ifndef TclNORM_LONG_PATH
	    /*
	     * Now we convert the tail of the current path to its 'long
	     * form', and append it to 'dsNorm' which holds the current
	     * normalized path
	     */

	    if (isDrive) {
		WCHAR drive = ((WCHAR *) nativePath)[0];

		if (drive >= L'a') {
		    drive -= (L'a' - L'A');
................................................................................
			checkDots++;
		    }
		}
		if (checkDots != NULL) {
		    int dotLen = currentPathEndPosition-lastValidPathEnd;

		    /*
		     * Path is just dots. We shouldn't really ever see a
		     * path like that. However, to be nice we at least
		     * don't mangle the path - we just add the dots as a
		     * path segment and continue.
		     */

		    Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
			    + Tcl_DStringLength(&ds)
			    - (dotLen * sizeof(WCHAR)),
			    dotLen * sizeof(WCHAR));
		} else {
................................................................................

		    WIN32_FIND_DATAW fData;
		    HANDLE handle;

		    handle = FindFirstFileW((WCHAR *) nativePath, &fData);
		    if (handle == INVALID_HANDLE_VALUE) {
			/*
			 * This is usually the '/' in 'c:/' at end of
			 * string.
			 */

			Tcl_DStringAppend(&dsNorm, (const char *) L"/",
				sizeof(WCHAR));
		    } else {
			WCHAR *nativeName;

................................................................................
	    Tcl_DStringFree(&ds);
	    lastValidPathEnd = currentPathEndPosition;
	    if (cur == 0) {
		break;
	    }

	    /*
	     * If we get here, we've got past one directory delimiter, so
	     * we know it is no longer a drive.
	     */

	    isDrive = 0;
	}
	currentPathEndPosition++;

#ifdef TclNORM_LONG_PATH
................................................................................
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}


	/* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */


    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}


	/* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */



	Tcl_IncrRefCount(validPathPtr);
    }

    str = TclGetStringFromObj(validPathPtr, &len);

    if (strlen(str) != len) {

	/* String contains NUL-bytes. This is invalid. */


	goto done;
    }


    /* For a reserved device, strip a possible postfix ':' */


    len = WinIsReserved(str);
    if (len == 0) {

	/* Let MultiByteToWideChar check for other invalid sequences, like
	 * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */


	len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
	if (len==0) {
	    goto done;
	}
    }


    /* Overallocate 6 chars, making some room for extended paths */


    wp = nativePathPtr = Tcl_Alloc( (len+6) * sizeof(WCHAR) );
    if (nativePathPtr==0) {
      goto done;
    }
    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1);


    /*
    ** If path starts with "//?/" or "\\?\" (extended path), translate
    ** any slashes to backslashes but leave the '?' intact
    */
    if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/')
	    && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) {



	wp[0] = wp[1] = wp[3] = '\\';
	str += 4;
	wp += 4;
    }

    /*
    ** If there is no "\\?\" prefix but there is a drive or UNC
    ** path prefix and the path is larger than MAX_PATH chars,
    ** no Win32 API function can handle that unless it is
    ** prefixed with the extended path prefix. See:
    ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
    **/
    if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z'))


	    && str[1]==':') {
	if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) {


	    memmove(wp+4, wp, len*sizeof(WCHAR));
	    memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR));
	    wp += 4;
	}

	/*
	 ** If (remainder of) path starts with "<drive>:",
	 ** leave the ':' intact.
	 */

	wp += 2;
    } else if (wp==nativePathPtr && len>MAX_PATH
	    && (str[0]=='\\' || str[0]=='/')
	    && (str[1]=='\\' || str[1]=='/') && str[2]!='?') {

	memmove(wp+6, wp, len*sizeof(WCHAR));
	memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR));
	wp += 7;
    }

    /*
    ** In the remainder of the path, translate invalid characters to
    ** characters in the Unicode private use area.
    */

    while (*wp != '\0') {
	if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
	    *wp |= 0xF000;
	} else if (*wp == '/') {
	    *wp = '\\';
	}
	++wp;
    }

  done:

    TclDecrRefCount(validPathPtr);
    return nativePathPtr;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
    LPBYTE buf = NULL;
    DWORD bufsz;
    int owned = 0;

    native = Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
                             OWNER_SECURITY_INFORMATION, &ownerSid,
                             NULL, NULL, NULL, &secd) != ERROR_SUCCESS) {

        /* Either not a file, or we do not have access to it in which
           case we are in all likelihood not the owner */


        return 0;
    }

    /*
     * Getting the current process SID is a multi-step process.
     * We make the assumption that if a call fails, this process is
     * so underprivileged it could not possibly own anything. Normally
     * a process can *always* look up its own token.
     */

    if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {

        /* Find out how big the buffer needs to be */


        bufsz = 0;
        GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
        if (bufsz) {
            buf = Tcl_Alloc(bufsz);
            if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
                owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
            }
        }
        CloseHandle(token);
    }


    /* Free allocations and be done */


    if (secd)
        LocalFree(secd);            /* Also frees ownerSid */

    if (buf)
        Tcl_Free(buf);


    return (owned != 0);        /* Convert non-0 to 1 */
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    const WCHAR *linkDirPath,	/* The junction to read */
    REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
    DWORD desiredAccess)
{
    HANDLE hFile;
    DWORD returnedLength;

    hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
	    OPEN_EXISTING,
	    FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);

    if (hFile == INVALID_HANDLE_VALUE) {
	/*
	 * Error creating directory.
	 */

................................................................................
	OutputDebugStringW(msgString);
    } else {
	MessageBeep(MB_ICONEXCLAMATION);
	MessageBoxW(NULL, msgString, L"Fatal Error",
		MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
    }
}
 
/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This function computes the absolute path name of the current
 *	application.
................................................................................
    Tcl_DStringInit(bufferPtr);

    wDomain = NULL;
    domain = Tcl_UtfFindFirst(name, '@');
    if (domain == NULL) {
	const char *ptr;

	/*
	 * No domain. Firstly check it's the current user
	 */

	ptr = TclpGetUserName(&ds);
	if (ptr != NULL && strcasecmp(name, ptr) == 0) {

	    /*
	     * Try safest and fastest way to get current user home
	     */

	    ptr = TclGetEnv("HOME", &ds);
	    if (ptr != NULL) {
		Tcl_JoinPath(1, &ptr, bufferPtr);
		rc = 1;
		result = Tcl_DStringValue(bufferPtr);
	    }
	}
................................................................................
	nameLen = domain - name;
    }
    if (rc == 0) {
	Tcl_DStringInit(&ds);
	wName = TclUtfToWCharDString(name, nameLen, &ds);
	while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
	    /*
	     * User does not exist; if domain was not specified, try again
	     * using current domain.
	     */

	    rc = 1;
	    if (domain != NULL) {
		break;
	    }

	    /*
	     * Get current domain
	     */

	    rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
	    if (rc != 0) {
		break;
	    }
	    domain = INT2PTR(-1); /* repeat once */
	}
	if (rc == 0) {
	    DWORD i, size = MAX_PATH;

	    wHomeDir = uiPtr->usri1_home_dir;
	    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
		size = lstrlenW(wHomeDir);
		TclWCharToUtfDString(wHomeDir, size, bufferPtr);
	    } else {
		/*
		 * User exists but has no home dir. Return
		 * "{GetProfilesDirectory}/<user>".
		 */

		GetProfilesDirectoryW(buf, &size);
		TclWCharToUtfDString(buf, size-1, bufferPtr);
		Tcl_DStringAppend(bufferPtr, "/", 1);
		Tcl_DStringAppend(bufferPtr, name, nameLen);
	    }
	    result = Tcl_DStringValue(bufferPtr);

	    /*
	     * Be sure we return normalized path
	     */

	    for (i = 0; i < size; ++i) {
		if (result[i] == '\\') {
		    result[i] = '/';
		}
	    }
	    NetApiBufferFree((void *) uiPtr);
	}
	Tcl_DStringFree(&ds);
    }
    if (wDomain != NULL) {
	NetApiBufferFree((void *) wDomain);
................................................................................

	return 0;
    }

    /*
     * If it's not a directory (assume file), do several fast checks:
     */

    if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*
	 * If the attributes say this is not writable at all.  The file is a
	 * regular file (i.e., not a directory), then the file is not
	 * writable, full stop.  For directories, the read-only bit is
	 * (mostly) ignored by Windows, so we can't ascertain anything about
	 * directory access from the attrib data.  However, if we have the
	 * advanced 'getFileSecurityProc', then more robust ACL checks will be
	 * done below.
	 */

	if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}

	/*
	 * If doesn't have the correct extension, it can't be executable
	 */

	if ((mode & X_OK) && !NativeIsExec(nativePath)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}

	/*
	 * Special case for read/write/executable check on file
	 */

	if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
	    DWORD mask = 0;
	    HANDLE hFile;

	    if (mode & R_OK) {
		mask |= GENERIC_READ;
	    }
	    if (mode & W_OK) {
		mask |= GENERIC_WRITE;
	    }
	    if (mode & X_OK) {
		mask |= GENERIC_EXECUTE;
	    }

	    hFile = CreateFile(nativePath, mask,
		    FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
		    NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
	    if (hFile != INVALID_HANDLE_VALUE) {
		CloseHandle(hFile);
		return 0;
	    }

	    /*
	     * Fast exit if access was denied
	     */

	    if (GetLastError() == ERROR_ACCESS_DENIED) {
		Tcl_SetErrno(EACCES);
		return -1;
	    }
	}

	/*
	 * We cannnot verify the access fast, check it below using security
	 * info.
	 */
    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
     * The code below is remarkably complex for such a simple thing as finding
     * what permissions the OS has set for a file.
................................................................................
    /*
     * If we can use 'createFile' on this, then we can use the resulting
     * fileHandle to read more information (nlink, ino) than we can get from
     * other attributes reading APIs. If not, then we try to fall back on the
     * 'getFileAttributesExProc', and if that isn't available, then on even
     * simpler routines.
     *
     * Special consideration must be given to Windows hardcoded names like
     * CON, NULL, COM1, LPT1 etc. For these, we still need to do the
     * CreateFile as some may not exist (e.g. there is no CON in wish by
     * default). However the subsequent GetFileInformationByHandle will
     * fail. We do a WinIsReserved to see if it is one of the special names,
     * and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.

     */

    fileHandle = CreateFile(nativePath, GENERIC_READ,
	    FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
	    NULL, OPEN_EXISTING,
	    FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);

................................................................................
	if (GetFileInformationByHandle(fileHandle,&data) != TRUE) {
            fileType = GetFileType(fileHandle);
            CloseHandle(fileHandle);
            if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) {
                Tcl_SetErrno(ENOENT);
                return -1;
            }

            /*
	     * Mock up the expected structure
	     */

            memset(&data, 0, sizeof(data));
            statPtr->st_atime = 0;
            statPtr->st_mtime = 0;
            statPtr->st_ctime = 0;
        } else {
            CloseHandle(fileHandle);
            statPtr->st_atime = ToCTime(data.ftLastAccessTime);
................................................................................

    if (GetCurrentDirectory(MAX_PATH, buffer) == 0) {
	TclWinConvertError(GetLastError());
	return NULL;
    }

    if (clientData != NULL) {
	if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
	    return clientData;
	}
    }

    return TclNativeDupInternalRep(buffer);
}
 
................................................................................
			    }
			}
			Tcl_DStringAppend(&dsNorm,
				(const char *)nativePath,
				(int)(sizeof(WCHAR) * len));
			lastValidPathEnd = currentPathEndPosition;
		    } else if (nextCheckpoint == 0) {
			/*
			 * Path starts with a drive designation that's not

			 * actually on the system. We still must normalize up
			 * past the first separator. [Bug 3603434]
			 */

			currentPathEndPosition++;
		    }
		}
		Tcl_DStringFree(&ds);
		break;
	    }

................................................................................
	    /*
	     * File 'nativePath' does exist if we get here. We now want to
	     * check if it is a symlink and otherwise continue with the
	     * rest of the path.
	     */

	    /*
	     * Check for symlinks, except at last component of path (we don't
	     * follow final symlinks). Also a drive (C:/) for example, may
	     * sometimes have the reparse flag set for some reason I don't
	     * understand. We therefore don't perform this check for drives.

	     */

	    if (cur != 0 && !isDrive &&
		    data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){
		Tcl_Obj *to = WinReadLinkDirectory(nativePath);

		if (to != NULL) {
		    /*
		     * Read the reparse point ok. Now, reparse points need not
		     * be normalized, otherwise we could use:
		     *
		     * Tcl_GetStringFromObj(to, &pathLen);
		     * nextCheckpoint = pathLen;
		     *
		     * So, instead we have to start from the beginning.
		     */

................................................................................
		    Tcl_DStringFree(&ds);
		    continue;
		}
	    }

#ifndef TclNORM_LONG_PATH
	    /*
	     * Now we convert the tail of the current path to its 'long form',
	     * and append it to 'dsNorm' which holds the current normalized
	     * path
	     */

	    if (isDrive) {
		WCHAR drive = ((WCHAR *) nativePath)[0];

		if (drive >= L'a') {
		    drive -= (L'a' - L'A');
................................................................................
			checkDots++;
		    }
		}
		if (checkDots != NULL) {
		    int dotLen = currentPathEndPosition-lastValidPathEnd;

		    /*
		     * Path is just dots. We shouldn't really ever see a path
		     * like that. However, to be nice we at least don't mangle
		     * the path - we just add the dots as a path segment and
		     * continue.
		     */

		    Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
			    + Tcl_DStringLength(&ds)
			    - (dotLen * sizeof(WCHAR)),
			    dotLen * sizeof(WCHAR));
		} else {
................................................................................

		    WIN32_FIND_DATAW fData;
		    HANDLE handle;

		    handle = FindFirstFileW((WCHAR *) nativePath, &fData);
		    if (handle == INVALID_HANDLE_VALUE) {
			/*
			 * This is usually the '/' in 'c:/' at end of string.

			 */

			Tcl_DStringAppend(&dsNorm, (const char *) L"/",
				sizeof(WCHAR));
		    } else {
			WCHAR *nativeName;

................................................................................
	    Tcl_DStringFree(&ds);
	    lastValidPathEnd = currentPathEndPosition;
	    if (cur == 0) {
		break;
	    }

	    /*
	     * If we get here, we've got past one directory delimiter, so we
	     * know it is no longer a drive.
	     */

	    isDrive = 0;
	}
	currentPathEndPosition++;

#ifdef TclNORM_LONG_PATH
................................................................................
	 * shorter so the utf-to-external conversion will be somewhat faster).
	 */

	validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}

	/*
	 * refCount of validPathPtr was already incremented in
	 * Tcl_FSGetTranslatedPath
	 */
    } else {
	/*
	 * Make sure the normalized path is set.
	 */

	validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
	if (validPathPtr == NULL) {
	    return NULL;
	}

	/*
	 * validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
	 * so incr refCount here
	 */

	Tcl_IncrRefCount(validPathPtr);
    }

    str = TclGetStringFromObj(validPathPtr, &len);

    if (strlen(str) != len) {
	/*
	 * String contains NUL-bytes. This is invalid.
	 */

	goto done;
    }

    /*
     * For a reserved device, strip a possible postfix ':'
     */

    len = WinIsReserved(str);
    if (len == 0) {
	/*
	 * Let MultiByteToWideChar check for other invalid sequences, like
	 * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames
	 */

	len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0);
	if (len==0) {
	    goto done;
	}
    }

    /*
     * Overallocate 6 chars, making some room for extended paths
     */

    wp = nativePathPtr = Tcl_Alloc((len + 6) * sizeof(WCHAR));
    if (nativePathPtr==0) {
      goto done;
    }
    MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
	    len + 1);

    /*
     * If path starts with "//?/" or "\\?\" (extended path), translate any
     * slashes to backslashes but leave the '?' intact
     */



    if ((str[0] == '\\' || str[0] == '/') && (str[1] == '\\' || str[1] == '/')
	    && str[2] == '?' && (str[3] == '\\' || str[3] == '/')) {
	wp[0] = wp[1] = wp[3] = '\\';
	str += 4;
	wp += 4;
    }

    /*
     * If there is no "\\?\" prefix but there is a drive or UNC path prefix
     * and the path is larger than MAX_PATH chars, no Win32 API function can

     * handle that unless it is prefixed with the extended path prefix. See:
     * <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath>
     */


    if (((str[0] >= 'A' && str[0] <= 'Z') || (str[0] >= 'a' && str[0] <= 'z'))
	    && str[1] == ':') {

	if (wp == nativePathPtr && len > MAX_PATH
		&& (str[2] == '\\' || str[2] == '/')) {
	    memmove(wp + 4, wp, len * sizeof(WCHAR));
	    memcpy(wp, L"\\\\?\\", 4 * sizeof(WCHAR));
	    wp += 4;
	}

	/*
	 * If (remainder of) path starts with "<drive>:", leave the ':'
	 * intact.
	 */

	wp += 2;
    } else if (wp == nativePathPtr && len > MAX_PATH
	    && (str[0] == '\\' || str[0] == '/')

	    && (str[1] == '\\' || str[1] == '/') && str[2] != '?') {
	memmove(wp + 6, wp, len * sizeof(WCHAR));
	memcpy(wp, L"\\\\?\\UNC", 7 * sizeof(WCHAR));
	wp += 7;
    }

    /*
     * In the remainder of the path, translate invalid characters to
     * characters in the Unicode private use area.
     */

    while (*wp != '\0') {
	if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) {
	    *wp |= 0xF000;
	} else if (*wp == '/') {
	    *wp = '\\';
	}
	++wp;
    }

  done:

    TclDecrRefCount(validPathPtr);
    return nativePathPtr;
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
    LPBYTE buf = NULL;
    DWORD bufsz;
    int owned = 0;

    native = Tcl_FSGetNativePath(pathPtr);

    if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT,
	    OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
	    &secd) != ERROR_SUCCESS) {
        /*
	 * Either not a file, or we do not have access to it in which case we
	 * are in all likelihood not the owner.
	 */

        return 0;
    }

    /*
     * Getting the current process SID is a multi-step process.  We make the
     * assumption that if a call fails, this process is so underprivileged it
     * could not possibly own anything. Normally a process can *always* look
     * up its own token.
     */

    if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) {
        /*
	 * Find out how big the buffer needs to be.
	 */

        bufsz = 0;
        GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
        if (bufsz) {
            buf = Tcl_Alloc(bufsz);
            if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
                owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
            }
        }
        CloseHandle(token);
    }

    /*
     * Free allocations and be done.
     */

    if (secd) {
        LocalFree(secd);            /* Also frees ownerSid */
    }
    if (buf) {
        Tcl_Free(buf);
    }

    return (owned != 0);        /* Convert non-0 to 1 */
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    DWORD writeError;		/* An error caused by the last background
				 * write. Set to 0 if no error has been
				 * detected. This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object.
				 */
    char *writeBuf;		/* Current background output buffer. Access is
				 * synchronized with the writable object. */
    int writeBufLen;		/* Size of write buffer. Access is
				 * synchronized with the writable object. */
    int toWrite;		/* Current amount to be written. Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
................................................................................
    PipeGetHandleProc,		/* Get an OS handle from channel. */
    PipeClose2Proc,		/* close2proc */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    PipeThreadActionProc,	/* thread action proc */
    NULL                       /* truncate */
};
 
/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

static const char *
BuildCmdLineBypassBS(
    const char *current,
    const char **bspos
) {


    /* mark first backslash possition */


    if (!*bspos) {
	*bspos = current;
    }
    do {
	current++;
    } while (*current == '\\');
    return current;
................................................................................
}

static void
QuoteCmdLineBackslash(
    Tcl_DString *dsPtr,
    const char *start,
    const char *current,
    const char *bspos
) {

    if (!bspos) {
	if (current > start) { /* part before current (special) */
	    Tcl_DStringAppend(dsPtr, start, (int) (current - start));
	}
    } else {
    	if (bspos > start) { /* part before first backslash */
	    Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
	}
	while (bspos++ < current) { /* each backslash twice */
	    TclDStringAppendLiteral(dsPtr, "\\\\");
	}
    }
}
................................................................................

static const char *
QuoteCmdLinePart(
    Tcl_DString *dsPtr,
    const char *start,
    const char *special,
    const char *specMetaChars,
    const char **bspos
) {

    if (!*bspos) {

	/* rest before special (before quote) */


	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
	start = special;
    } else {

	/* rest before first backslash and backslashes into new quoted block */


	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
	start = *bspos;
    }

    /*
     * escape all special chars enclosed in quotes like `"..."`, note that here we
     * don't must escape `\` (with `\`), because it's outside of the main quotes,
     * so `\` remains `\`, but important - not at end of part, because results as
     * before the quote,  so `%\%\` should be escaped as `"%\%"\\`).

     */

    TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
    do {
    	*bspos = NULL;
	special++;
	if (*special == '\\') {

	    /* bypass backslashes (and mark first backslash possition)*/


	    special = BuildCmdLineBypassBS(special, bspos);
	    if (*special == '\0') break;


	}
    } while (*special && strchr(specMetaChars, *special));
    if (!*bspos) {

	/* unescaped rest before quote */


	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
    } else {

	/* unescaped rest before first backslash (rather belongs to the main block) */



	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
    }
    TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
    return special;
}

static void
................................................................................
    const char **argv,		/* Argument strings in UTF. */
    Tcl_DString *linePtr)	/* Initialized Tcl_DString that receives the
				 * command line (WCHAR). */
{
    const char *arg, *start, *special, *bspos;
    int quote = 0, i;
    Tcl_DString ds;

    /* characters to enclose in quotes if unpaired quote flag set */
    static const char specMetaChars[] = "&|^<>!()%";
    /* character to enclose in quotes in any case (regardless unpaired-flag) */
    static const char specMetaChars2[] = "%";

    /* Quote flags:

     *   CL_ESCAPE   - escape argument;
     *   CL_QUOTE    - enclose in quotes;
     *   CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
     */
    enum {CL_ESCAPE = 1, CL_QUOTE = 2, CL_UNPAIRED = 4};

    Tcl_DStringInit(&ds);
................................................................................

	quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */
	bspos = NULL;
	if (arg[0] == '\0') {
	    quote = CL_QUOTE;
	} else {
	    for (start = arg;
		*start != '\0' &&
		    (quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
		start++
	    ) {
		if (*start & 0x80) continue;


		if (TclIsSpaceProc(*start)) {
		    quote |= CL_QUOTE; /* quote only */
		    if (bspos) { /* if backslash found - escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
		if (strchr(specMetaChars, *start)) {
		    quote |= (CL_ESCAPE|CL_QUOTE); /*escape & quote */
		    break;
		}
		if (*start == '"') {
		    quote |= CL_ESCAPE; /* escape only */
		    continue;
		}
		if (*start == '\\') {
		    bspos = start;
		    if (quote & CL_QUOTE) { /* if quote - escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
	    }
	    bspos = NULL;
	}
	if (quote & CL_QUOTE) {

	    /* start of argument (main opening quote-char) */


	    TclDStringAppendLiteral(&ds, "\"");
	}
	if (!(quote & CL_ESCAPE)) {

	    /* nothing to escape */


	    Tcl_DStringAppend(&ds, arg, -1);
	} else {
	    start = arg;
	    for (special = arg; *special != '\0'; ) {

		/* position of `\` is important before quote or at end (equal `\"` because quoted) */



		if (*special == '\\') {

		    /* bypass backslashes (and mark first backslash possition)*/


		    special = BuildCmdLineBypassBS(special, &bspos);
		    if (*special == '\0') break;


		}
		/* ["] */
		if (*special == '"') {

		    quote ^= CL_UNPAIRED; /* invert unpaired flag - observe unpaired quotes */





		    /* add part before (and escape backslashes before quote) */


		    QuoteCmdLineBackslash(&ds, start, special, bspos);
		    bspos = NULL;


		    /* escape using backslash */


		    TclDStringAppendLiteral(&ds, "\\\"");
		    start = ++special;
		    continue;
		}


		/* unpaired (escaped) quote causes special handling on meta-chars */



		if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special, specMetaChars, &bspos);



		    /* start to current or first backslash */


		    start = !bspos ? special : bspos;
		    continue;
		}


		/* special case for % - should be enclosed always (paired also) */



		if (strchr(specMetaChars2, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special, specMetaChars2, &bspos);



		    /* start to current or first backslash */


		    start = !bspos ? special : bspos;
		    continue;
		}


		/* other not special (and not meta) character */


		bspos = NULL; /* reset last backslash possition (not interesting) */

		special++;
	    }


	    /* rest of argument (and escape backslashes before closing main quote) */



	    QuoteCmdLineBackslash(&ds, start, special,
	    	(quote & CL_QUOTE) ? bspos : NULL);
	}
	if (quote & CL_QUOTE) {

	    /* end of argument (main closing quote-char) */


	    TclDStringAppendLiteral(&ds, "\"");
	}
    }
    Tcl_DStringFree(linePtr);
    Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
    Tcl_DStringFree(&ds);
}
................................................................................
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->writeFile;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /* avoid blocking if pipe-thread exited */

    timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI)
	|| TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EWOULDBLOCK;
................................................................................
     * Since most of the work is handled by the background threads, we just
     * need to update the watchMask and then force the notifier to poll once.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };

	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstPipePtr;
	    tsdPtr->firstPipePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);
    } else {
	if (oldMask) {
................................................................................
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeReaderThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg;
    PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
    HANDLE handle = NULL;
    DWORD count, err;
    int done = 0;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to wait on the
	 * pipe becoming readable.
	 */

	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */
	    break;
	}

	if (!infoPtr) {
	    infoPtr = (PipeInfo *)pipeTI->clientData;
	    handle = ((WinFile *) infoPtr->readFile)->handle;
	}

	/*
	 * Try waiting for 0 bytes. This will block until some data is
	 * available on NT, but will return immediately on Win 95. So, if no
	 * data is available after the first read, we block until we can read
................................................................................
    HANDLE wakeEvent)
{
    TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
    pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
    pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo));
#endif
    pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
    pipeTI->state = PTI_STATE_IDLE;
    pipeTI->clientData = clientData;
    pipeTI->evWakeUp = wakeEvent;
    return (*pipeTIPtr = pipeTI);
}
 
................................................................................
    HANDLE wakeEvent;

    if (!pipeTI) {
	return 0;
    }

    wakeEvent = pipeTI->evWakeUp;

    /*
     * Wait for the main thread to signal before attempting to do the work.
     */


    /* reset work state of thread (idle/waiting) */


    if ((state = InterlockedCompareExchange(&pipeTI->state,

	    PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) {

	/* end of work, check the owner of structure */


	goto end;
    }


    /* entering wait */
    waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);



    if (waitResult != WAIT_OBJECT_0) {

	/*
	 * The control event was not signaled, so end of work (unexpected
	 * behaviour, main thread can be dead?).
	 */

	goto end;
    }


    /* try to set work state of thread */


    if ((state = InterlockedCompareExchange(&pipeTI->state,

	    PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) {

	/* end of work */


	goto end;
    }


    /* signaled to work */


    return 1;

end:

    /* end of work, check the owner of the TI structure */


    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;
    } else {
    	pipeTI->evWakeUp = NULL;
    }
    if (wakeEvent) {
    	SetEvent(wakeEvent);
................................................................................
 *	1 if signaled (or pipe-thread is down), 0 if pipe thread still working.
 *
 *----------------------------------------------------------------------
 */

int
TclPipeThreadStopSignal(
    TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent)

{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    HANDLE evControl;
    int state;

    if (!pipeTI) {
	return 1;
    }
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = wakeEvent;
    switch (
	(state = InterlockedCompareExchange(&pipeTI->state,
	    PTI_STATE_STOP, PTI_STATE_IDLE))
    ) {


	case PTI_STATE_IDLE:




	    /* Thread was idle/waiting, notify it goes teardown */
	    SetEvent(evControl);

	    *pipeTIPtr = NULL;

	case PTI_STATE_DOWN:

	return 1;

	default:
	    /*
	     * Thread works currently, we should try to end it, own the TI structure
	     * (because of possible sharing the joint structures with thread)

	     */

	    InterlockedExchange(&pipeTI->state, PTI_STATE_END);
	break;
    }

    return 0;
}
 
/*
................................................................................

    if (!pipeTI) {
	return;
    }
    pipeTI = *pipeTIPtr;
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = NULL;

    /*
     * Try to sane stop the pipe worker, corresponding its current state
     */
    switch (

	(state = InterlockedCompareExchange(&pipeTI->state,
	    PTI_STATE_STOP, PTI_STATE_IDLE))
    ) {

	case PTI_STATE_IDLE:




	    /* Thread was idle/waiting, notify it goes teardown */
	    SetEvent(evControl);


	    /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */



	    pipeTI = NULL;
	break;

	case PTI_STATE_STOP:

	    /* already stopped, thread frees himself (owns the TI structure) */


	    pipeTI = NULL;
	break;
	case PTI_STATE_DOWN:

	    /* Thread already down (?), do nothing */



	    /* we don't need to wait for it, but we should free pipeTI */

	    hThread = NULL;
	break;

	/* case PTI_STATE_WORK: */
	default:
	    /*
	     * Thread works currently, we should try to end it, own the TI structure
	     * (because of possible sharing the joint structures with thread)

	     */

	    if ((state = InterlockedCompareExchange(&pipeTI->state,
		    PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN
	    ) {


		/* we don't need to wait for it, but we should free pipeTI */

		hThread = NULL;
	    };

	break;
    }

    if (pipeTI && hThread) {
	DWORD exitCode;

	/*
................................................................................
	 * The thread may already have closed on its own. Check its exit
	 * code.
	 */

	GetExitCodeThread(hThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {

	    int inExit = (TclInExit() || TclInThreadExit());

	    /*
	     * Set the stop event so that if the pipe thread is blocked
	     * somewhere, it may hereafter sane exit cleanly.
	     */

	    SetEvent(evControl);

	    /*
	     * Cancel all sync-IO of this thread (may be blocked there).
	     */

	    if (tclWinProcs.cancelSynchronousIo) {
		tclWinProcs.cancelSynchronousIo(hThread);
	    }

	    /*
	     * Wait at most 20 milliseconds for the reader thread to
	     * close (regarding TIP#398-fast-exit).
	     */


	    /* if we want TIP#398-fast-exit. */
	    if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {



		/*
		 * The thread must be blocked waiting for the pipe to
		 * become readable in ReadFile(). There isn't a clean way
		 * to exit the thread from this condition. We should
		 * terminate the child process instead to get the reader
		 * thread to fall out of ReadFile with a FALSE. (below) is
		 * not the correct way to do this, but will stay here
		 * until a better solution is found.
		 *
		 * Note that we need to guard against terminating the
		 * thread while it is in the middle of Tcl_ThreadAlert
		 * because it won't be able to release the notifier lock.
		 *
		 * Also note that terminating threads during their initialization or teardown phase

		 * may result in ntdll.dll's LoaderLock to remain locked indefinitely.
		 * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock.
		 * LdrpInitializeThread() is executed within new threads to perform

		 * initialization and to execute DllMain() of all loaded dlls.
		 * As a result, all new threads are deadlocked in their initialization phase and never execute,
		 * even though CreateThread() reports successful thread creation.

		 * This results in a very weird process-wide behavior, which is extremely hard to debug.
		 *
		 * THREADS SHOULD NEVER BE TERMINATED. Period.
		 *
		 * But for now, check if thread is exiting, and if so, let it die peacefully.

		 *
		 * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's).

		 */

		if ( pipeTI->state != PTI_STATE_DOWN
		  && WaitForSingleObject(hThread,
			inExit ? 50 : 5000) != WAIT_OBJECT_0
		) {
		    /* BUG: this leaks memory */
		    if (inExit || !TerminateThread(hThread, 0)) {

			/* in exit or terminate fails, just give thread a chance to exit */



			if (InterlockedExchange(&pipeTI->state,
				PTI_STATE_STOP) != PTI_STATE_DOWN) {
			    pipeTI = NULL;
			}
		    };
		}
	    }
	}
    }

    *pipeTIPtr = NULL;
    if (pipeTI) {
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
	CloseHandle(pipeTI->evControl);
#   ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#   else
	Tcl_Free(pipeTI);
#   endif
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadExit --
................................................................................

void
TclPipeThreadExit(
    TclPipeThreadInfo **pipeTIPtr)
{
    LONG state;
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    /*
     * If state of thread was set to stop (exactly), we can sane free its info
     * structure, otherwise it is shared with main thread, so main thread will
     * own it.
     */

    if (!pipeTI) {
	return;
    }
    *pipeTIPtr = NULL;
    if ((state = InterlockedExchange(&pipeTI->state,
	    PTI_STATE_DOWN)) == PTI_STATE_STOP) {
	CloseHandle(pipeTI->evControl);
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
#   ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#   else
	Tcl_Free(pipeTI);
	/* be sure all subsystems used are finalized */
	Tcl_FinalizeThread();
#   endif
    }
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    HANDLE readable;		/* Manual-reset event to signal when the
				 * reader thread has finished waiting for
				 * input. */
    DWORD writeError;		/* An error caused by the last background
				 * write. Set to 0 if no error has been
				 * detected. This word is shared with the
				 * writer thread so access must be
				 * synchronized with the writable object. */

    char *writeBuf;		/* Current background output buffer. Access is
				 * synchronized with the writable object. */
    int writeBufLen;		/* Size of write buffer. Access is
				 * synchronized with the writable object. */
    int toWrite;		/* Current amount to be written. Access is
				 * synchronized with the writable object. */
    int readFlags;		/* Flags that are shared with the reader
................................................................................
    PipeGetHandleProc,		/* Get an OS handle from channel. */
    PipeClose2Proc,		/* close2proc */
    PipeBlockModeProc,		/* Set blocking or non-blocking mode.*/
    NULL,			/* flush proc. */
    NULL,			/* handler proc. */
    NULL,			/* wide seek proc */
    PipeThreadActionProc,	/* thread action proc */
    NULL			/* truncate */
};
 
/*
 *----------------------------------------------------------------------
 *
 * PipeInit --
 *
................................................................................
 *
 *----------------------------------------------------------------------
 */

static const char *
BuildCmdLineBypassBS(
    const char *current,
    const char **bspos)

{
    /*
     * Mark first backslash position.
     */

    if (!*bspos) {
	*bspos = current;
    }
    do {
	current++;
    } while (*current == '\\');
    return current;
................................................................................
}

static void
QuoteCmdLineBackslash(
    Tcl_DString *dsPtr,
    const char *start,
    const char *current,
    const char *bspos)

{
    if (!bspos) {
	if (current > start) {	/* part before current (special) */
	    Tcl_DStringAppend(dsPtr, start, (int) (current - start));
	}
    } else {
    	if (bspos > start) {	/* part before first backslash */
	    Tcl_DStringAppend(dsPtr, start, (int) (bspos - start));
	}
	while (bspos++ < current) { /* each backslash twice */
	    TclDStringAppendLiteral(dsPtr, "\\\\");
	}
    }
}
................................................................................

static const char *
QuoteCmdLinePart(
    Tcl_DString *dsPtr,
    const char *start,
    const char *special,
    const char *specMetaChars,
    const char **bspos)

{
    if (!*bspos) {
	/*
	 * Rest before special (before quote).
	 */

	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
	start = special;
    } else {
	/*
	 * Rest before first backslash and backslashes into new quoted block.
	 */

	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
	start = *bspos;
    }

    /*
     * escape all special chars enclosed in quotes like `"..."`, note that
     * here we don't must escape `\` (with `\`), because it's outside of the
     * main quotes, so `\` remains `\`, but important - not at end of part,
     * because results as before the quote, so `%\%\` should be escaped as
     * `"%\%"\\`).
     */

    TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
    do {
    	*bspos = NULL;
	special++;
	if (*special == '\\') {
	    /*
	     * Bypass backslashes (and mark first backslash position).
	     */

	    special = BuildCmdLineBypassBS(special, bspos);
	    if (*special == '\0') {
		break;
	    }
	}
    } while (*special && strchr(specMetaChars, *special));
    if (!*bspos) {
	/*
	 * Unescaped rest before quote.
	 */

	QuoteCmdLineBackslash(dsPtr, start, special, NULL);
    } else {
	/*
	 * Unescaped rest before first backslash (rather belongs to the main
	 * block).
	 */

	QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
    }
    TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */
    return special;
}

static void
................................................................................
    const char **argv,		/* Argument strings in UTF. */
    Tcl_DString *linePtr)	/* Initialized Tcl_DString that receives the
				 * command line (WCHAR). */
{
    const char *arg, *start, *special, *bspos;
    int quote = 0, i;
    Tcl_DString ds;
    static const char specMetaChars[] = "&|^<>!()%";
				/* Characters to enclose in quotes if unpaired
				 * quote flag set. */
    static const char specMetaChars2[] = "%";
				/* Character to enclose in quotes in any case
				 * (regardless of unpaired-flag). */
    /*
     * Quote flags:
     *   CL_ESCAPE   - escape argument;
     *   CL_QUOTE    - enclose in quotes;
     *   CL_UNPAIRED - previous arguments chain contains unpaired quote-char;
     */
    enum {CL_ESCAPE = 1, CL_QUOTE = 2, CL_UNPAIRED = 4};

    Tcl_DStringInit(&ds);
................................................................................

	quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */
	bspos = NULL;
	if (arg[0] == '\0') {
	    quote = CL_QUOTE;
	} else {
	    for (start = arg;
		    *start != '\0' &&
			(quote & (CL_ESCAPE|CL_QUOTE)) != (CL_ESCAPE|CL_QUOTE);
		    start++) {

		if (*start & 0x80) {
		    continue;
		}
		if (TclIsSpaceProc(*start)) {
		    quote |= CL_QUOTE;	/* quote only */
		    if (bspos) {	/* if backslash found, escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
		if (strchr(specMetaChars, *start)) {
		    quote |= (CL_ESCAPE|CL_QUOTE); /* escape & quote */
		    break;
		}
		if (*start == '"') {
		    quote |= CL_ESCAPE;		/* escape only */
		    continue;
		}
		if (*start == '\\') {
		    bspos = start;
		    if (quote & CL_QUOTE) {	/* if quote, escape & quote */
			quote |= CL_ESCAPE;
			break;
		    }
		    continue;
		}
	    }
	    bspos = NULL;
	}
	if (quote & CL_QUOTE) {
	    /*
	     * Start of argument (main opening quote-char).
	     */

	    TclDStringAppendLiteral(&ds, "\"");
	}
	if (!(quote & CL_ESCAPE)) {
	    /*
	     * Nothing to escape.
	     */

	    Tcl_DStringAppend(&ds, arg, -1);
	} else {
	    start = arg;
	    for (special = arg; *special != '\0'; ) {
		/*
		 * Position of `\` is important before quote or at end (equal
		 * `\"` because quoted).
		 */

		if (*special == '\\') {
		    /*
		     * Bypass backslashes (and mark first backslash position)
		     */

		    special = BuildCmdLineBypassBS(special, &bspos);
		    if (*special == '\0') {
			break;
		    }
		}
		/* ["] */
		if (*special == '"') {
		    /*
		     * Invert the unpaired flag - observe unpaired quotes
		     */

		    quote ^= CL_UNPAIRED;

		    /*
		     * Add part before (and escape backslashes before quote).
		     */

		    QuoteCmdLineBackslash(&ds, start, special, bspos);
		    bspos = NULL;

		    /*
		     * Escape using backslash
		     */

		    TclDStringAppendLiteral(&ds, "\\\"");
		    start = ++special;
		    continue;
		}

		/*
		 * Unpaired (escaped) quote causes special handling on
		 * meta-chars
		 */

		if ((quote & CL_UNPAIRED) && strchr(specMetaChars, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special,
			    specMetaChars, &bspos);

		    /*
		     * Start to current or first backslash
		     */

		    start = !bspos ? special : bspos;
		    continue;
		}

		/*
		 * Special case for % - should be enclosed always (paired
		 * also)
		 */

		if (strchr(specMetaChars2, *special)) {
		    special = QuoteCmdLinePart(&ds, start, special,
			    specMetaChars2, &bspos);

		    /*
		     * Start to current or first backslash.
		     */

		    start = !bspos ? special : bspos;
		    continue;
		}

		/*
		 * Other not special (and not meta) character
		 */

		bspos = NULL;		/* reset last backslash position (not
					 * interesting) */
		special++;
	    }

	    /*
	     * Rest of argument (and escape backslashes before closing main
	     * quote)
	     */

	    QuoteCmdLineBackslash(&ds, start, special,
		    (quote & CL_QUOTE) ? bspos : NULL);
	}
	if (quote & CL_QUOTE) {
	    /*
	     * End of argument (main closing quote-char)
	     */

	    TclDStringAppendLiteral(&ds, "\"");
	}
    }
    Tcl_DStringFree(linePtr);
    Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
    Tcl_DStringFree(&ds);
}
................................................................................
    PipeInfo *infoPtr = (PipeInfo *) instanceData;
    WinFile *filePtr = (WinFile*) infoPtr->writeFile;
    DWORD bytesWritten, timeout;

    *errorCode = 0;

    /* avoid blocking if pipe-thread exited */
    timeout = ((infoPtr->flags & PIPE_ASYNC)
	    || !TclPipeThreadIsAlive(&infoPtr->writeTI)
	    || TclInExit() || TclInThreadExit()) ? 0 : INFINITE;
    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
	/*
	 * The writer thread is blocked waiting for a write to complete and
	 * the channel is in non-blocking mode.
	 */

	errno = EWOULDBLOCK;
................................................................................
     * Since most of the work is handled by the background threads, we just
     * need to update the watchMask and then force the notifier to poll once.
     */

    infoPtr->watchMask = mask & infoPtr->validMask;
    if (infoPtr->watchMask) {
	Tcl_Time blockTime = { 0, 0 };

	if (!oldMask) {
	    infoPtr->nextPtr = tsdPtr->firstPipePtr;
	    tsdPtr->firstPipePtr = infoPtr;
	}
	Tcl_SetMaxBlockTime(&blockTime);
    } else {
	if (oldMask) {
................................................................................
 *----------------------------------------------------------------------
 */

static DWORD WINAPI
PipeReaderThread(
    LPVOID arg)
{
    TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg;
    PipeInfo *infoPtr = NULL; /* access info only after success init/wait */
    HANDLE handle = NULL;
    DWORD count, err;
    int done = 0;

    while (!done) {
	/*
	 * Wait for the main thread to signal before attempting to wait on the
	 * pipe becoming readable.
	 */

	if (!TclPipeThreadWaitForSignal(&pipeTI)) {
	    /* exit */
	    break;
	}

	if (!infoPtr) {
	    infoPtr = (PipeInfo *) pipeTI->clientData;
	    handle = ((WinFile *) infoPtr->readFile)->handle;
	}

	/*
	 * Try waiting for 0 bytes. This will block until some data is
	 * available on NT, but will return immediately on Win 95. So, if no
	 * data is available after the first read, we block until we can read
................................................................................
    HANDLE wakeEvent)
{
    TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
    pipeTI = malloc(sizeof(TclPipeThreadInfo));
#else
    pipeTI = Tcl_Alloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
    pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL);
    pipeTI->state = PTI_STATE_IDLE;
    pipeTI->clientData = clientData;
    pipeTI->evWakeUp = wakeEvent;
    return (*pipeTIPtr = pipeTI);
}
 
................................................................................
    HANDLE wakeEvent;

    if (!pipeTI) {
	return 0;
    }

    wakeEvent = pipeTI->evWakeUp;

    /*
     * Wait for the main thread to signal before attempting to do the work.
     */

    /*
     * Reset work state of thread (idle/waiting)
     */

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_IDLE,
	    PTI_STATE_WORK);
    if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
	/*
	 * End of work, check the owner of structure.
	 */

	goto end;
    }

    /*
     * Entering wait

     */

    waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE);
    if (waitResult != WAIT_OBJECT_0) {

	/*
	 * The control event was not signaled, so end of work (unexpected
	 * behaviour, main thread can be dead?).
	 */

	goto end;
    }

    /*
     * Try to set work state of thread
     */

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_WORK,
	    PTI_STATE_IDLE);
    if (state & (PTI_STATE_STOP|PTI_STATE_END)) {
	/*
	 * End of work
	 */

	goto end;
    }

    /*
     * Signaled to work.
     */

    return 1;

  end:
    /*
     * End of work, check the owner of the TI structure.
     */

    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;
    } else {
    	pipeTI->evWakeUp = NULL;
    }
    if (wakeEvent) {
    	SetEvent(wakeEvent);
................................................................................
 *	1 if signaled (or pipe-thread is down), 0 if pipe thread still working.
 *
 *----------------------------------------------------------------------
 */

int
TclPipeThreadStopSignal(
    TclPipeThreadInfo **pipeTIPtr,
    HANDLE wakeEvent)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    HANDLE evControl;
    int state;

    if (!pipeTI) {
	return 1;
    }
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = wakeEvent;

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
	    PTI_STATE_IDLE);


    switch (state) {
    case PTI_STATE_IDLE:
	/*
	 * Thread was idle/waiting, notify it goes teardown
	 */


	SetEvent(evControl);

	*pipeTIPtr = NULL;

    case PTI_STATE_DOWN:

	return 1;

    default:
	/*
	 * Thread works currently, we should try to end it, own the TI
	 * structure (because of possible sharing the joint structures with
	 * thread)
	 */

	InterlockedExchange(&pipeTI->state, PTI_STATE_END);
	break;
    }

    return 0;
}
 
/*
................................................................................

    if (!pipeTI) {
	return;
    }
    pipeTI = *pipeTIPtr;
    evControl = pipeTI->evControl;
    pipeTI->evWakeUp = NULL;

    /*
     * Try to sane stop the pipe worker, corresponding its current state
     */


    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
	    PTI_STATE_IDLE);
    switch (state) {

    case PTI_STATE_IDLE:
	/*
	 * Thread was idle/waiting, notify it goes teardown
	 */


	SetEvent(evControl);

	/*
	 * We don't need to wait for it at all, thread frees himself (owns the
	 * TI structure)
	 */

	pipeTI = NULL;
	break;

    case PTI_STATE_STOP:
	/*
	 * Already stopped, thread frees himself (owns the TI structure)
	 */

	pipeTI = NULL;
	break;
    case PTI_STATE_DOWN:
	/*
	 * Thread already down (?), do nothing
	 */

	/*
	 * We don't need to wait for it, but we should free pipeTI
	 */
	hThread = NULL;
	break;

	/* case PTI_STATE_WORK: */
    default:
	/*
	 * Thread works currently, we should try to end it, own the TI
	 * structure (because of possible sharing the joint structures with
	 * thread)
	 */

	state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_END,
		PTI_STATE_WORK);

	if (state == PTI_STATE_DOWN) {
	    /*
	     * We don't need to wait for it, but we should free pipeTI
	     */
	    hThread = NULL;

	}
	break;
    }

    if (pipeTI && hThread) {
	DWORD exitCode;

	/*
................................................................................
	 * The thread may already have closed on its own. Check its exit
	 * code.
	 */

	GetExitCodeThread(hThread, &exitCode);

	if (exitCode == STILL_ACTIVE) {

	    int inExit = (TclInExit() || TclInThreadExit());

	    /*
	     * Set the stop event so that if the pipe thread is blocked
	     * somewhere, it may hereafter sane exit cleanly.
	     */

	    SetEvent(evControl);

	    /*
	     * Cancel all sync-IO of this thread (may be blocked there).
	     */

	    if (tclWinProcs.cancelSynchronousIo) {
		tclWinProcs.cancelSynchronousIo(hThread);
	    }

	    /*
	     * Wait at most 20 milliseconds for the reader thread to close
	     * (regarding TIP#398-fast-exit).
	     */

	    /*
	     * If we want TIP#398-fast-exit.

	     */

	    if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) {
		/*
		 * The thread must be blocked waiting for the pipe to become
		 * readable in ReadFile(). There isn't a clean way to exit the
		 * thread from this condition. We should terminate the child
		 * process instead to get the reader thread to fall out of
		 * ReadFile with a FALSE. (below) is not the correct way to do

		 * this, but will stay here until a better solution is found.
		 *
		 * Note that we need to guard against terminating the thread
		 * while it is in the middle of Tcl_ThreadAlert because it
		 * won't be able to release the notifier lock.
		 *
		 * Also note that terminating threads during their
		 * initialization or teardown phase may result in ntdll.dll's
		 * LoaderLock to remain locked indefinitely.  This causes
		 * ntdll.dll's LdrpInitializeThread() to deadlock trying to
		 * acquire LoaderLock.  LdrpInitializeThread() is executed
		 * within new threads to perform initialization and to execute
		 * DllMain() of all loaded dlls.  As a result, all new threads
		 * are deadlocked in their initialization phase and never
		 * execute, even though CreateThread() reports successful
		 * thread creation.  This results in a very weird process-wide
		 * behavior, which is extremely hard to debug.
		 *
		 * THREADS SHOULD NEVER BE TERMINATED. Period.
		 *
		 * But for now, check if thread is exiting, and if so, let it
		 * die peacefully.
		 *
		 * Also don't terminate if in exit (otherwise deadlocked in
		 * ntdll.dll's).
		 */

		if (pipeTI->state != PTI_STATE_DOWN
			&& WaitForSingleObject(hThread,
				inExit ? 50 : 5000) != WAIT_OBJECT_0) {

		    /* BUG: this leaks memory */
		    if (inExit || !TerminateThread(hThread, 0)) {
			/*
			 * in exit or terminate fails, just give thread a
			 * chance to exit
			 */

			if (InterlockedExchange(&pipeTI->state,
				PTI_STATE_STOP) != PTI_STATE_DOWN) {
			    pipeTI = NULL;
			}
		    }
		}
	    }
	}
    }

    *pipeTIPtr = NULL;
    if (pipeTI) {
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
	CloseHandle(pipeTI->evControl);
#ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#else
	Tcl_Free(pipeTI);
#endif /* !_PTI_USE_CKALLOC */
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadExit --
................................................................................

void
TclPipeThreadExit(
    TclPipeThreadInfo **pipeTIPtr)
{
    LONG state;
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;

    /*
     * If state of thread was set to stop (exactly), we can sane free its info
     * structure, otherwise it is shared with main thread, so main thread will
     * own it.
     */

    if (!pipeTI) {
	return;
    }
    *pipeTIPtr = NULL;
    state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN);
    if (state == PTI_STATE_STOP) {
	CloseHandle(pipeTI->evControl);
	if (pipeTI->evWakeUp) {
	    SetEvent(pipeTI->evWakeUp);
	}
#ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#else
	Tcl_Free(pipeTI);
	/* be sure all subsystems used are finalized */
	Tcl_FinalizeThread();
#endif /* !_PTI_USE_CKALLOC */
    }
}
 
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */