Tcl_Obj *numberObj)
{
    void *clientData;
    int tcl_number_type;

    if (Tcl_GetNumberFromObj(interp, numberObj, &clientData,
		&tcl_number_type) != TCL_OK) {
	return TCL_ERROR;
    }
    if (tcl_number_type == TCL_NUMBER_BIG) {
	/* bignum is not supported yet. */
	Tcl_WideInt w;
	(void)Tcl_GetWideIntFromObj(interp, numberObj, &w);
	return TCL_ERROR;
    }
    if (useDoubles) {
	if (tcl_number_type != TCL_NUMBER_INT) {
	    *dblNumberPtr = *(double *)clientData;
	} else {

TclNRAssembleObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    ByteCode *codePtr;		/* Pointer to the bytecode to execute */



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

    /*
     * Assemble the source to bytecode.
     */

    codePtr = CompileAssembleObj(interp, objv[1]);

    /*
     * On failure, report error line.
     */

    if (codePtr == NULL) {

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"%s\" body, line %d)",
		TclGetString(objv[0]), Tcl_GetErrorLine(interp)));


	return TCL_ERROR;
    }

    /*
     * Use NRE to evaluate the bytecode from the trampoline.
     */

    const char *dstStart, *dstEnd;
    int result, numChars, charLimit = INT_MAX;
    int ch;
    int profile;

    if (flags & TCL_ENCODING_START) {
        /* *statePtr will hold high surrogate in a split surrogate pair */
	*statePtr = 0;
    }
    result = TCL_OK;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {

    Tcl_Command token,		/* The ensemble to configure. */
    int objc,			/* The count of option-related arguments. */
    Tcl_Obj *const objv[])	/* Option-related arguments. */
{
    Tcl_Size len;
    int allocatedMapFlag = 0;
    Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
	    *unknownObj = NULL;		/* Defaults, silence gcc 4 warnings */
    Tcl_Obj *listObj;
    Tcl_DictSearch search;
    int permitPrefix, flags = 0;	/* silence gcc 4 warning */
    enum EnsConfigOpts index;
    int done;

    Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);

     *
     * Tcl_SplitList must work correctly when interp is NULL.
     */

    if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
    invAccessMode:
	if (interp != NULL) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    while processing open access modes \"%s\"",
		    modeString));

	    Tcl_SetErrorCode(interp, "TCL", "OPENMODE", "INVALID", (char *)NULL);
	}
	if (modeArgv) {
	    Tcl_Free((void *)modeArgv);
	}
	return -1;
    }

    gotRW = 0;
    for (i = 0; i < modeArgc; i++) {
	flag = modeArgv[i];
	c = flag[0];
	if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
	    if (gotRW) {
	    invRW:
		if (interp != NULL) {
		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			    "invalid access mode \"%s\": modes RDONLY, "
			    "RDWR, and WRONLY cannot be combined", flag));
		}
		goto invAccessMode;
	    }
	    mode = (mode & ~O_ACCMODE) | O_RDONLY;
	    gotRW = 1;
	} else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
	    if (gotRW) {

/*
 * tclIcu.c --
 *
 *	tclIcu.c implements various Tcl commands that make use of
 *	the ICU library if present on the system.
 *	(Adapted from tkIcu.c)
 *
 * Copyright © 2021 Jan Nijtmans
 * Copyright © 2024 Ashok P. Nadkarni
 *
 * See the file "license.terms" for information on usage and redistribution of

#include "tclInt.h"
#include "tclOOInt.h"

/*
 * Commands in oo::define and oo::objdefine.
 */

enum {
    ON_CLASS = 0,		// Implementation works on class
    ON_INSTANCE = 1,		// Implementation works on instance
    IGNORED = 0			// Value ignored by implementation
};

static const struct DefinitionCommandDescriptor {
    const char *name;		// Definition name (NULL in last record)
    Tcl_ObjCmdProc *objProc;	// Definition implementation
    int flag;			// "Is instance" flag; passed as clientData
} defineCmds[] = {
    {"constructor",	TclOODefineConstructorObjCmd, IGNORED},
    {"definitionnamespace", TclOODefineDefnNsObjCmd, IGNORED},
    {"deletemethod",	TclOODefineDeleteMethodObjCmd, ON_CLASS},
    {"destructor",	TclOODefineDestructorObjCmd, IGNORED},
    {"export",		TclOODefineExportObjCmd, ON_CLASS},
    {"forward",		TclOODefineForwardObjCmd, ON_CLASS},
    {"method",		TclOODefineMethodObjCmd, ON_CLASS},
    {"private",		TclOODefinePrivateObjCmd, ON_CLASS},
    {"renamemethod",	TclOODefineRenameMethodObjCmd, ON_CLASS},
    {"self",		TclOODefineSelfObjCmd, IGNORED},
    {"unexport",	TclOODefineUnexportObjCmd, ON_CLASS},
    {NULL, NULL, IGNORED}
}, objdefCmds[] = {
    {"class",		TclOODefineClassObjCmd, IGNORED},
    {"deletemethod",	TclOODefineDeleteMethodObjCmd, ON_INSTANCE},
    {"export",		TclOODefineExportObjCmd, ON_INSTANCE},
    {"forward",		TclOODefineForwardObjCmd, ON_INSTANCE},
    {"method",		TclOODefineMethodObjCmd, ON_INSTANCE},
    {"private",		TclOODefinePrivateObjCmd, ON_INSTANCE},
    {"renamemethod",	TclOODefineRenameMethodObjCmd, ON_INSTANCE},
    {"self",		TclOODefineObjSelfObjCmd, IGNORED},
    {"unexport",	TclOODefineUnexportObjCmd, ON_INSTANCE},
    {NULL, NULL, IGNORED}
};

/*
 * What sort of size of things we like to allocate.
 */

#define ALLOC_CHUNK 8

/*
 * The actual definition of the variable holding the TclOO stub table.
 */

MODULE_SCOPE const TclOOStubs tclOOStubs;








/*
 * Macros to make inspecting into the guts of an object cleaner.
 *
 * The ocPtr parameter (only in these macros) is assumed to work fine with
 * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
 * have _both_ their object and class flags tagged with ROOT_OBJECT and
 * ROOT_CLASS respectively.

    const char *name,
    Tcl_ObjCmdProc *cmdProc,
    Tcl_ObjCmdProc *nreProc,
    CompileProc *compileProc)
{
    Command *cmdPtr;

    if (!cmdProc && !nreProc) {
	Tcl_Panic("must supply at least one implementation function");
    }
    cmdPtr = (Command *) TclCreateObjCommandInNs(interp, name,
	    namespacePtr, cmdProc, NULL, NULL);
    cmdPtr->nreProc = nreProc;
    cmdPtr->compileProc = compileProc;
}

    /*
     * Make the configurable class and install its standard defined method.
     */

    Tcl_Object cfgCls = Tcl_NewObjectInstance(interp,
	    (Tcl_Class) fPtr->classCls,
	    "::oo::configuresupport::configurable", NULL, TCL_INDEX_NONE, NULL,
	    TCL_INDEX_NONE);
    for (i = 0 ; cfgMethods[i].name ; i++) {
	TclOONewBasicMethod(((Object *) cfgCls)->classPtr, &cfgMethods[i]);
    }

    /*
     * Don't have handles to these namespaces, so use Tcl_CreateObjCommand.
     */

				 * will be the same as if this was NULL. */
{
    Foundation *fPtr = GetFoundation(interp);
    Object *oPtr;
    Command *cmdPtr;
    CommandTrace *tracePtr;
    size_t creationEpoch;
    int errorInNsManufacture;

    oPtr = (Object *) Tcl_Alloc(sizeof(Object));
    memset(oPtr, 0, sizeof(Object));

    /*
     * Every object has a namespace; make one. Note that this also computes the
     * creation epoch value for the object, a sequence number that is unique to
     * the object (and which allows us to manage method caching without
     * comparing pointers).
     *
     * When creating a namespace, we first check to see if the caller
     * specified the name for the namespace. If not, we generate namespace
     * names using the epoch until such time as a new namespace is actually
     * created.
     */

    if (nsNameStr) {
	oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL);
	if (!oPtr->namespacePtr) {
	    /*
	     * Couldn't make the specific namespace. Report as an error.
	     * [Bug 154f0982f2]
	     */
	    Tcl_Free(oPtr);
	    return NULL;
	}
	creationEpoch = ++fPtr->tsdPtr->nsCount;
	goto configNamespace;
    }

    errorInNsManufacture = 0;
    do {
	char objName[10 + TCL_INTEGER_SPACE];

	snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u",
		++fPtr->tsdPtr->nsCount);
	oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
	errorInNsManufacture |= !oPtr->namespacePtr;
    } while (!oPtr->namespacePtr);


    if (errorInNsManufacture) {
	/*

	 * We have to get rid of error messages from failed calls to
	 * Tcl_CreateNamespace, since that's something that should not be
	 * exposed to the user.
	 */

	Tcl_ResetResult(interp);
    }
    creationEpoch = fPtr->tsdPtr->nsCount;

  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) {
	TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
    }
    TclOOSetupVariableResolver(oPtr->namespacePtr);

    /*
     * Suppress use of compiled versions of the commands in this object's
     * namespace and its children; causes wrong behaviour without expensive

     * public command (so that the object structures are deleted when the
     * command is deleted).
     */

    if (!nameStr) {
	nameStr = oPtr->namespacePtr->name;
	nsPtr = (Namespace *) oPtr->namespacePtr;
	if (nsPtr->parentPtr) {
	    nsPtr = nsPtr->parentPtr;
	}
    }
    oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
	    (Tcl_Namespace *) nsPtr, TclOOPublicObjectCmd, oPtr, NULL);

    /*
     * Add the NRE command and trace directly. While this breaks a number of
     * abstractions, it is faster and we're inside Tcl here so we're allowed.
     */

    cmdPtr = (Command *) oPtr->command;
    cmdPtr->nreProc = PublicNRObjectCmd;
    cmdPtr->tracePtr = tracePtr = (CommandTrace *)
	    Tcl_Alloc(sizeof(CommandTrace));
    tracePtr->traceProc = ObjectRenamedTrace;
    tracePtr->clientData = oPtr;
    tracePtr->flags = TCL_TRACE_RENAME | TCL_TRACE_DELETE;
    tracePtr->nextPtr = NULL;
    tracePtr->refCount = 1;

    oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
	    TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
    oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
	    oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,

	clsPtr->filters.num = 0;
    }

    /*
     * Squelch our metadata.
     */

    if (clsPtr->metadataPtr) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	void *value;

	FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(clsPtr->metadataPtr);

    Object *oPtr = (Object *) clientData;
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = fPtr->interp;
    Tcl_Size i;

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

	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
	int result;
	Tcl_InterpState state;

	oPtr->flags |= DESTRUCTOR_CALLED;

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

    TclOORemoveFromInstances(oPtr, oPtr->selfCls);

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

    FOREACH(filterObj, oPtr->filters) {
	TclDecrRefCount(filterObj);
    }

    if (oPtr->chainCache) {
	TclOODeleteChainCache(oPtr->chainCache);
    }

    SquelchCachedName(oPtr);

    if (oPtr->metadataPtr) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	void *value;

	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(oPtr->metadataPtr);

     */

    if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
	    && !Tcl_InterpDeleted(interp)) {
	Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
    }

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

    /*
     * Delete the object structure itself.
     */

 * ----------------------------------------------------------------------
 */

int
TclOODecrRefCount(
    Object *oPtr)
{
    if (oPtr->refCount-- > 1) {
	return 0;
    }

    if (oPtr->classPtr) {
	Tcl_Free(oPtr->classPtr);
    }
    Tcl_Free(oPtr);
    return 1;


}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOObjectDestroyed --
 *
 *	Returns TCL_OK if an object is entirely deleted, i.e. the destruction
 *	sequence has completed.
 *
 * ----------------------------------------------------------------------
 */
int
TclOOObjectDestroyed(
    Object *oPtr)
{
    return !oPtr->namespacePtr;
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOORemoveFromInstances --
 *

static inline void
InitClassPath(
    Tcl_Interp *interp,
    Class *clsPtr)
{
    Foundation *fPtr = GetFoundation(interp);

    if (fPtr->helpersNs) {
	Tcl_Namespace *path[2];

	path[0] = fPtr->helpersNs;
	path[1] = fPtr->ooNs;
	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
    } else {
	TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,

				 * constructor. */
{
    Class *classPtr = (Class *) cls;
    Object *oPtr;
    void *clientData[4];

    oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
    if (!oPtr) {
	return NULL;
    }

    /*
     * Run constructors, except when objc < 0, which is a special flag case
     * used for object cloning only.
     */

    if (objc != TCL_INDEX_NONE) {
	CallContext *contextPtr =
		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);

	if (contextPtr) {
	    int isRoot, result;
	    Tcl_InterpState state;

	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;

{
    Class *classPtr = (Class *) cls;
    CallContext *contextPtr;
    Tcl_InterpState state;
    Object *oPtr;

    oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
    if (!oPtr) {
	return TCL_ERROR;
    }

    /*
     * Run constructors, except when objc == TCL_INDEX_NONE (a special flag
     * case used for object cloning only). If there aren't any constructors,
     * we do nothing.
     */

    if (objc < 0) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;
    }
    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
    if (!contextPtr) {
	*objectPtr = (Tcl_Object) oPtr;
	return TCL_OK;
    }

    state = Tcl_SaveInterpState(interp, TCL_OK);
    contextPtr->callPtr->flags |= CONSTRUCTOR;
    contextPtr->skip = skip;

    }

    /*
     * Create the object.
     */

    oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
    if (!oPtr) {
	return NULL;
    }
    oPtr->selfCls = classPtr;
    AddRef(classPtr->thisPtr);
    TclOOAddToInstances(oPtr, classPtr);

    /*

    /*
     * Ensure an error if the object was deleted in the constructor. Don't
     * want to lose errors by accident. [Bug 2903011]
     */

    if (result != TCL_ERROR && Destructing(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object deleted in constructor", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", (char *)NULL);
	result = TCL_ERROR;
    }
    if (result != TCL_OK) {
	Tcl_DiscardInterpState(state);

	/*

Tcl_CopyObjectInstance(
    Tcl_Interp *interp,
    Tcl_Object sourceObject,
    const char *targetName,
    const char *targetNamespaceName)
{
    Object *oPtr = (Object *) sourceObject, *o2Ptr;
    Foundation *fPtr = GetFoundation(interp);
    FOREACH_HASH_DECLS;
    Method *mPtr;
    Class *mixinPtr;
    CallContext *contextPtr;
    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
    PrivateVariableMapping *privateVariable;
    Tcl_Size i;
    int result;

    /*
     * Sanity check.
     */

    if (IsRootClass(oPtr)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not clone the class of classes", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", (char *)NULL);
	return NULL;
    }

    /*
     * Build the instance. Note that this does not run any constructors.
     */

    o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
	    (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName,
	    TCL_INDEX_NONE, NULL, TCL_INDEX_NONE);
    if (!o2Ptr) {
	return NULL;
    }

    /*
     * Copy the object-local methods to the new object.
     */

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

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

    if (oPtr->metadataPtr) {
	Tcl_ObjectMetadataType *metadataTypePtr;
	void *value, *duplicate;

	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
	    if (!metadataTypePtr->cloneProc) {
		duplicate = value;
	    } else {
		if (metadataTypePtr->cloneProc(interp, value,
			&duplicate) != TCL_OK) {
		    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
		    return NULL;
		}
	    }
	    if (duplicate) {
		Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
			duplicate);
	    }
	}
    }

    /*
     * Copy the class, if present. Note that if there is a class present in
     * the source object, there must also be one in the copy.
     */

    if (oPtr->classPtr) {
	Class *clsPtr = oPtr->classPtr;
	Class *cls2Ptr = o2Ptr->classPtr;
	Class *superPtr;

	/*
	 * Copy the class flags across.
	 */

	    }
	}

	/*
	 * Duplicate the class's metadata.
	 */

	if (clsPtr->metadataPtr) {
	    Tcl_ObjectMetadataType *metadataTypePtr;
	    void *value, *duplicate;

	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
		if (!metadataTypePtr->cloneProc) {
		    duplicate = value;
		} else {
		    if (metadataTypePtr->cloneProc(interp, value,
			    &duplicate) != TCL_OK) {
			Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
			return NULL;
		    }
		}
		if (duplicate) {
		    Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
			    duplicate);
		}
	    }
	}
    }

    TclResetRewriteEnsemble(interp, 1);
    contextPtr = TclOOGetCallContext(o2Ptr, fPtr->clonedName, 0, NULL,
	    NULL, NULL);
    if (contextPtr) {
	args[0] = TclOOObjectName(interp, o2Ptr);
	args[1] = fPtr->clonedName;
	args[2] = TclOOObjectName(interp, oPtr);
	Tcl_IncrRefCount(args[0]);
	Tcl_IncrRefCount(args[1]);
	Tcl_IncrRefCount(args[2]);
	result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3,
		args);
	TclDecrRefCount(args[0]);

static int
CloneObjectMethod(
    Tcl_Interp *interp,
    Object *oPtr,
    Method *mPtr,
    Tcl_Obj *namePtr)
{
    if (!mPtr->typePtr) {
	TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
		mPtr->flags & PUBLIC_METHOD, NULL, NULL);
    } else if (mPtr->typePtr->cloneProc) {
	void *newClientData;

	if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
		&newClientData) != TCL_OK) {

    Class *clsPtr,
    Method *mPtr,
    Tcl_Obj *namePtr,
    Method **m2PtrPtr)
{
    Method *m2Ptr;

    if (!mPtr->typePtr) {
	m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
		namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
    } else if (mPtr->typePtr->cloneProc) {
	void *newClientData;

	if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
		&newClientData) != TCL_OK) {
	    return TCL_ERROR;
	}
	m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
		newClientData);
    } else {
	m2Ptr = (Method *) TclNewMethod((Tcl_Class) clsPtr,
		namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
		mPtr->clientData);
    }
    if (m2PtrPtr) {
	*m2PtrPtr = m2Ptr;
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------

    Tcl_HashEntry *hPtr;

    /*
     * If there's no metadata store attached, the type in question has
     * definitely not been attached either!
     */

    if (!clsPtr->metadataPtr) {
	return NULL;
    }

    /*
     * There is a metadata store, so look in it for the given type.
     */

    hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr);

    /*
     * Return the metadata value if we found it, otherwise NULL.
     */

    if (!hPtr) {
	return NULL;
    }
    return Tcl_GetHashValue(hPtr);
}

void
Tcl_ClassSetMetadata(
    Tcl_Class clazz,
    const Tcl_ObjectMetadataType *typePtr,
    void *metadata)
{
    Class *clsPtr = (Class *) clazz;
    Tcl_HashEntry *hPtr;
    int isNew;

    /*
     * Attach the metadata store if not done already.
     */

    if (!clsPtr->metadataPtr) {
	if (!metadata) {
	    return;
	}
	clsPtr->metadataPtr = (Tcl_HashTable *)
		Tcl_Alloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
    }

    /*
     * If the metadata is NULL, we're deleting the metadata for the type.
     */

    if (!metadata) {
	hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr);
	if (hPtr) {
	    typePtr->deleteProc(Tcl_GetHashValue(hPtr));
	    Tcl_DeleteHashEntry(hPtr);
	}
	return;
    }

    /*

    Tcl_HashEntry *hPtr;

    /*
     * If there's no metadata store attached, the type in question has
     * definitely not been attached either!
     */

    if (!oPtr->metadataPtr) {
	return NULL;
    }

    /*
     * There is a metadata store, so look in it for the given type.
     */

    hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr);

    /*
     * Return the metadata value if we found it, otherwise NULL.
     */

    if (!hPtr) {
	return NULL;
    }
    return Tcl_GetHashValue(hPtr);
}

void
Tcl_ObjectSetMetadata(
    Tcl_Object object,
    const Tcl_ObjectMetadataType *typePtr,
    void *metadata)
{
    Object *oPtr = (Object *) object;
    Tcl_HashEntry *hPtr;
    int isNew;

    /*
     * Attach the metadata store if not done already.
     */

    if (!oPtr->metadataPtr) {
	if (!metadata) {
	    return;
	}
	oPtr->metadataPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
    }

    /*
     * If the metadata is NULL, we're deleting the metadata for the type.
     */

    if (!metadata) {
	hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr);
	if (hPtr) {
	    typePtr->deleteProc(Tcl_GetHashValue(hPtr));
	    Tcl_DeleteHashEntry(hPtr);
	}
	return;
    }

    /*

    }

    /*
     * Give plugged in code a chance to remap the method name.
     */

    methodNamePtr = objv[1];
    if (oPtr->mapMethodNameProc) {
	Class **startClsPtr = &startCls;
	Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);

	result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
		(Tcl_Class *) startClsPtr, mappedMethodName);
	if (result != TCL_OK) {
	    TclDecrRefCount(mappedMethodName);

	 */

	Tcl_IncrRefCount(mappedMethodName);
	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
		callerClsPtr, methodNamePtr);
	TclDecrRefCount(mappedMethodName);
	if (!contextPtr) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "impossible to invoke method \"%s\": no defined method or"
		    " unknown method", TclGetString(methodNamePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
		    TclGetString(methodNamePtr), (char *)NULL);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * Get the call chain.
	 */

    noMapping:
	contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
		callerClsPtr, NULL);
	if (!contextPtr) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "impossible to invoke method \"%s\": no defined method or"
		    " unknown method", TclGetString(methodNamePtr)));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(methodNamePtr), (char *)NULL);
	    return TCL_ERROR;
	}
    }

    /*
     * Check to see if we need to apply magical tricks to start part way
     * through the call chain.
     */

    if (startCls) {
	for (; contextPtr->index < contextPtr->callPtr->numChain;
		contextPtr->index++) {
	    MInvoke *miPtr = &contextPtr->callPtr->chain[contextPtr->index];

	    if (miPtr->isFilter) {
		continue;
	    }
	    if (miPtr->mPtr->declaringClassPtr == startCls) {
		break;
	    }
	}
	if (contextPtr->index >= contextPtr->callPtr->numChain) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "no valid method implementation", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(methodNamePtr), (char *)NULL);
	    TclOODeleteContext(contextPtr);
	    return TCL_ERROR;
	}
    }

				 * Will have an error message placed in it if
				 * the name does not refer to an object. */
    Tcl_Obj *objPtr)		/* The name of the object to look up, which is
				 * exactly the name of its public command. */
{
    Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);

    if (!cmdPtr) {
	goto notAnObject;
    }
    if (cmdPtr->objProc != TclOOPublicObjectCmd) {
	cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
	if (!cmdPtr || cmdPtr->objProc != TclOOPublicObjectCmd) {
	    goto notAnObject;
	}
    }
    return (Tcl_Object) cmdPtr->objClientData;

  notAnObject:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(

Tcl_Obj *
Tcl_GetObjectClassName(
    Tcl_Interp *interp,
    Tcl_Object object)
{
    Tcl_Object classObj = (Tcl_Object) (((Object *) object)->selfCls)->thisPtr;

    if (!classObj) {
	return NULL;
    }
    return Tcl_GetObjectName(interp, classObj);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
    Foundation *fPtr = GetFoundation(interp);
    Tcl_Obj **invoke, *nameObj;

    size_t skip = Tcl_ObjectContextSkippedArgs(context);
    if ((size_t) objc > skip + 1) {
	Tcl_WrongNumArgs(interp, skip, objv,
		"?definitionScript?");
	return TCL_ERROR;
    } else if ((size_t) objc == skip) {
	return TCL_OK;
    }

    /*
     * Make the class definition delegate. This is special; it doesn't reenter
     * here (and the class definition delegate doesn't run any constructors).
     */

    nameObj = Tcl_ObjPrintf("%s:: oo ::delegate",
	    oPtr->namespacePtr->fullName);
    Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls,
	    TclGetString(nameObj), NULL, TCL_INDEX_NONE, NULL, TCL_INDEX_NONE);
    Tcl_BounceRefCount(nameObj);

    /*
     * Delegate to [oo::define] to do the work.
     */

    invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *));
    invoke[0] = fPtr->defineName;
    invoke[1] = TclOOObjectName(interp, oPtr);
    invoke[2] = objv[objc - 1];

    /*
     * Must add references or errors in configuration script will cause
     * trouble.
     */

    Tcl_IncrRefCount(invoke[0]);

    Object *oPtr = (Object *) data[1];
    Tcl_InterpState saved;
    int code;

    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);
    TclDecrRefCount(invoke[2]);
    invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", TCL_AUTO_LENGTH);
    invoke[1] = TclOOObjectName(interp, oPtr);
    Tcl_IncrRefCount(invoke[0]);
    Tcl_IncrRefCount(invoke[1]);
    saved = Tcl_SaveInterpState(interp, result);
    code = Tcl_EvalObjv(interp, 2, invoke, 0);
    TclDecrRefCount(invoke[0]);
    TclDecrRefCount(invoke[1]);

    Tcl_Size len;

    /*
     * Sanity check; should not be possible to invoke this method on a
     * non-class.
     */

    if (!oPtr->classPtr) {
	Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);

	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"object \"%s\" is not a class", TclGetString(cmdnameObj)));
	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL);
	return TCL_ERROR;
    }

		"objectName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */

    Tcl_Size len;

    /*
     * Sanity check; should not be possible to invoke this method on a
     * non-class.
     */

    if (!oPtr->classPtr) {
	Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);

	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"object \"%s\" is not a class", TclGetString(cmdnameObj)));
	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL);
	return TCL_ERROR;
    }

		"objectName namespaceName ?arg ...?");
	return TCL_ERROR;
    }
    objName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"object name must not be empty", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL);
	return TCL_ERROR;
    }
    nsName = Tcl_GetStringFromObj(
	    objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
    if (len == 0) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"namespace name must not be empty", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Make the object and return its name.
     */

    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);

    /*
     * Sanity check; should not be possible to invoke this method on a
     * non-class.
     */

    if (!oPtr->classPtr) {
	Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);

	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"object \"%s\" is not a class", TclGetString(cmdnameObj)));
	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", (char *)NULL);
	return TCL_ERROR;
    }

		NULL);
	return TCL_ERROR;
    }
    if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
	oPtr->flags |= DESTRUCTOR_CALLED;
	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
		NULL);
	if (contextPtr) {
	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
		    NULL, NULL, NULL);
	    TclPushTailcallPoint(interp);
	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
	}

	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[skip]), (char *)NULL);
	return TCL_ERROR;
    }

    errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
	    TclGetString(objv[skip]));
    for (i=0 ; i<numMethodNames - 1 ; i++) {
	if (i) {
	    Tcl_AppendToObj(errorMsg, ", ", TCL_AUTO_LENGTH);
	}
	Tcl_AppendToObj(errorMsg, methodNames[i], TCL_AUTO_LENGTH);
    }
    if (i) {
	Tcl_AppendToObj(errorMsg, " or ", TCL_AUTO_LENGTH);
    }
    Tcl_AppendToObj(errorMsg, methodNames[i], TCL_AUTO_LENGTH);
    Tcl_Free((void *) methodNames);
    Tcl_SetObjResult(interp, errorMsg);
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[skip]), (char *)NULL);
    return TCL_ERROR;
}


    /*
     * A sanity check. Shouldn't ever happen. (This is all that remains of a
     * more complex check inherited from [global] after we have applied the
     * fix for [Bug 2903811]; note that the fix involved *removing* code.)
     */

    if (!iPtr->varFramePtr) {
	return TCL_OK;
    }

    for (i = Tcl_ObjectContextSkippedArgs(context) ; i < objc ; i++) {
	Var *varPtr, *aryPtr;
	const char *varName = TclGetString(objv[i]);

	/*
	 * The variable name must not contain a '::' since that's illegal in
	 * local names.
	 */

	if (strstr(varName, "::")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "variable name \"%s\" illegal: must not contain namespace"
		    " separator", varName));
	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", (char *)NULL);
	    return TCL_ERROR;
	}

	savedNsPtr = iPtr->varFramePtr->nsPtr;
	iPtr->varFramePtr->nsPtr = (Namespace *)
		Tcl_GetObjectNamespace(object);
	varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY,
		"define", 1, 0, &aryPtr);
	iPtr->varFramePtr->nsPtr = savedNsPtr;

	if (!varPtr || aryPtr) {
	    /*
	     * Variable cannot be an element in an array. If aryPtr is not
	     * NULL, it is an element, so throw up an error and return.
	     */

	    TclVarErrMsg(interp, varName, NULL, "define",
		    "name refers to an element in an array");

		namespacePtr->fullName, TclGetString(varName));
    }
    Tcl_IncrRefCount(varNamePtr);
    Tcl_Var var = (Tcl_Var) TclObjLookupVar(interp, varNamePtr, NULL,
	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1,
	    (Var **) aryPtr);
    Tcl_DecrRefCount(varNamePtr);
    if (!var) {
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, (void *) NULL);
    } else if (!*aryPtr && TclIsVarArrayElement((Var *) var)) {
	/*
	 * If the varPtr points to an element of an array but we don't already
	 * have the array, find it now. Note that this can't be easily
	 * backported; the arrayPtr field is new in Tcl 9.0. [Bug 2da1cb0c80]
	 */
	*aryPtr = (Tcl_Var) TclVarParentArray(var);
    }

	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"varName");
	return TCL_ERROR;
    }

    varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
	    objv[objc - 1], &aryVar);
    if (!varPtr) {
	return TCL_ERROR;
    }

    /*
     * The variable reference must not disappear too soon. [Bug 74b6110204]
     */
    if (!TclIsVarArrayElement((Var *) varPtr)) {
	TclSetVarNamespaceVar((Var *) varPtr);
    }

    /*
     * Now that we've pinned down what variable we're really talking about
     * (including traversing variable links), convert back to a name.
     */

    TclNewObj(varNamePtr);

    if (aryVar) {
	Tcl_GetVariableFullName(interp, aryVar, varNamePtr);
	Tcl_AppendPrintfToObj(varNamePtr, "(%s)", Tcl_GetString(
		VarHashGetKey(varPtr)));
    } else {
	Tcl_GetVariableFullName(interp, varPtr, varNamePtr);
    }
    Tcl_SetObjResult(interp, varNamePtr);

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

    if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
	return TCL_ERROR;
    }
    context = (Tcl_ObjectContext) framePtr->clientData;

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

    if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
	return TCL_ERROR;
    }
    contextPtr = (CallContext *) framePtr->clientData;

    /*
     * Sanity check the arguments; we need the first one to refer to a class.
     */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
	return TCL_ERROR;
    }
    object = Tcl_GetObjectFromObj(interp, objv[1]);
    if (!object) {
	return TCL_ERROR;
    }
    classPtr = ((Object *) object)->classPtr;
    if (!classPtr) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"\"%s\" is not a class", TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (char *)NULL);
	return TCL_ERROR;
    }

    /*

	    /*
	     * Invoke the (advanced) method call context in the caller
	     * context. Note that this is like [uplevel 1] and not [eval].
	     */

	    TclNRAddCallback(interp, NextRestoreFrame, framePtr,
		    contextPtr, INT2PTR(contextPtr->index), NULL);
	    contextPtr->index = i - 1;
	    iPtr->varFramePtr = framePtr->callerVarPtr;
	    return TclNRObjectContextInvokeNext(interp,
		    (Tcl_ObjectContext) contextPtr, objc, objv, 2);
	}
    }

    /*

    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;
    CallContext *contextPtr = (CallContext *) data[1];

    iPtr->varFramePtr = (CallFrame *) data[0];
    if (contextPtr) {
	contextPtr->index = PTR2UINT(data[2]);
    }
    return result;
}

/*
 * ----------------------------------------------------------------------

	"object", "target", NULL
    };
    enum SelfCmds {
	SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
	SELF_NEXT, SELF_OBJECT, SELF_TARGET
    } index;
    Interp *iPtr = (Interp *) interp;
    Foundation *fPtr = GetFoundation(interp);
    CallFrame *framePtr = iPtr->varFramePtr;
    CallContext *contextPtr;
    Tcl_Obj *result[3];

#define CurrentlyInvoked(contextPtr) \
    ((contextPtr)->callPtr->chain[(contextPtr)->index])

    /*
     * Start with sanity checks on the calling context and the method context.
     */

    if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s may only be called from inside a method",
		TclGetString(objv[0])));
	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
	return TCL_ERROR;
    }

    case SELF_NS:
	Tcl_SetObjResult(interp,
		TclNewNamespaceObj(contextPtr->oPtr->namespacePtr));
	return TCL_OK;
    case SELF_CLASS: {
	Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;

	if (!clsPtr) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "method not defined by a class", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
	    return TCL_ERROR;
	}

	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
	return TCL_OK;
    }
    case SELF_METHOD:
	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	    Tcl_SetObjResult(interp, fPtr->constructorName);
	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
	    Tcl_SetObjResult(interp, fPtr->destructorName);
	} else {
	    Tcl_SetObjResult(interp,
		    CurrentlyInvoked(contextPtr).mPtr->namePtr);
	}
	return TCL_OK;
    case SELF_FILTER:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
	    return TCL_ERROR;
	} else {
	    MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
	    Object *oPtr;
	    const char *type;

	    if (miPtr->filterDeclarer) {
		oPtr = miPtr->filterDeclarer->thisPtr;
		type = "class";
	    } else {
		oPtr = contextPtr->oPtr;
		type = "object";
	    }

	    result[0] = TclOOObjectName(interp, oPtr);
	    result[1] = Tcl_NewStringObj(type, TCL_AUTO_LENGTH);
	    result[2] = miPtr->mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_CALLER:
	if (!framePtr->callerVarPtr ||
		!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "caller is not an object", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (char *)NULL);
	    return TCL_ERROR;
	} else {
	    CallContext *callerPtr = (CallContext *)
		    framePtr->callerVarPtr->clientData;
	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
	    Object *declarerPtr;

	    if (mPtr->declaringClassPtr) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", TCL_AUTO_LENGTH));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = TclOOObjectName(interp, callerPtr->oPtr);
	    if (callerPtr->callPtr->flags & CONSTRUCTOR) {
		result[2] = fPtr->constructorName;
	    } else if (callerPtr->callPtr->flags & DESTRUCTOR) {
		result[2] = fPtr->destructorName;
	    } else {
		result[2] = mPtr->namePtr;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
	    return TCL_OK;
	}
    case SELF_NEXT:
	if (contextPtr->index < contextPtr->callPtr->numChain - 1) {
	    Method *mPtr =
		    contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
	    Object *declarerPtr;

	    if (mPtr->declaringClassPtr) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", TCL_AUTO_LENGTH));
		return TCL_ERROR;
	    }

	    result[0] = TclOOObjectName(interp, declarerPtr);
	    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
		result[1] = fPtr->constructorName;
	    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
		result[1] = fPtr->destructorName;
	    } else {
		result[1] = mPtr->namePtr;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	}
	return TCL_OK;
    case SELF_TARGET:
	if (!CurrentlyInvoked(contextPtr).isFilter) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "not inside a filtering context", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", (char *)NULL);
	    return TCL_ERROR;
	} else {
	    Method *mPtr;
	    Object *declarerPtr;
	    Tcl_Size i;

	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
		if (!contextPtr->callPtr->chain[i].isFilter) {
		    break;
		}
	    }
	    if (i == contextPtr->callPtr->numChain) {
		Tcl_Panic("filtering call chain without terminal non-filter");
	    }
	    mPtr = contextPtr->callPtr->chain[i].mPtr;
	    if (mPtr->declaringClassPtr) {
		declarerPtr = mPtr->declaringClassPtr->thisPtr;
	    } else if (mPtr->declaringObjectPtr) {
		declarerPtr = mPtr->declaringObjectPtr;
	    } else {
		/*
		 * This should be unreachable code.
		 */

		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"method without declarer!", TCL_AUTO_LENGTH));
		return TCL_ERROR;
	    }
	    result[0] = TclOOObjectName(interp, declarerPtr);
	    result[1] = mPtr->namePtr;
	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
	    return TCL_OK;
	}

    if (objc < 2 || objc > 4) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"sourceName ?targetName? ?targetNamespace?");
	return TCL_ERROR;
    }

    oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    /*
     * Create a cloned object of the correct class. Note that constructors are
     * not called. Also note that we must resolve the object name ourselves
     * because we do not want to create the object in the current namespace,

	namespaceName = NULL;
	if (objc == 4) {
	    namespaceName = TclGetString(objv[3]);

	    if (namespaceName[0] == '\0') {
		namespaceName = NULL;
	    } else if (Tcl_FindNamespace(interp, namespaceName, NULL, 0)) {

		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"%s refers to an existing namespace", namespaceName));
		return TCL_ERROR;
	    }
	}

	o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
    }

    if (!o2Ptr) {
	return TCL_ERROR;
    }

    /*
     * Return the name of the cloned object.
     */

void
TclOODeleteContext(
    CallContext *contextPtr)
{
    Object *oPtr = contextPtr->oPtr;

    TclOODeleteChain(contextPtr->callPtr);
    if (oPtr) {
	TclStackFree(oPtr->fPtr->interp, contextPtr);

	/*
	 * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore
	 */

	TclOODecrRefCount(oPtr);

 * ----------------------------------------------------------------------
 */

void
TclOODeleteChain(
    CallChain *callPtr)
{
    if (!callPtr || callPtr->refCount-- > 1) {
	return;
    }
    if (callPtr->chain != callPtr->staticChain) {
	Tcl_Free(callPtr->chain);
    }
    Tcl_Free(callPtr);
}

	Tcl_HashEntry *hPtr =
		Tcl_CreateHashEntry(namesPtr, namePtr, &isNew);

	if (isNew) {
	    int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
		    ? IN_LIST : 0;

	    isWanted |= (mPtr->typePtr ? 0 : NO_IMPLEMENTATION);
	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
	} else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
		&& mPtr->typePtr) {
	    int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));

	    isWanted &= ~NO_IMPLEMENTATION;
	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
	}
    }
}

{
    Tcl_HashEntry *hPtr;
    Method *mPtr;
    int donePrivate = 0;

    if (oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName);
	if (hPtr) {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
		donePrivate = 1;
	    }
	}
    }

    int foundPrivate = 0, blockedUnexported = 0;
    Tcl_HashEntry *hPtr;
    Method *mPtr;

    if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);

	if (hPtr) {
	    mPtr = (Method *) Tcl_GetHashValue(hPtr);
	    if (!IS_PRIVATE(mPtr)) {
		if (WANT_PUBLIC(flags)) {
		    if (!IS_PUBLIC(mPtr)) {
			blockedUnexported = 1;
		    } else {
			flags |= DEFINITE_PUBLIC;

	    }
	    foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
		    methodNameObj, cbPtr, doneFilters,
		    flags | TRAVERSED_MIXIN, filterDecl);
	}
	if (oPtr->methodsPtr && !blockedUnexported) {
	    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj);
	    if (hPtr) {
		mPtr = (Method *) Tcl_GetHashValue(hPtr);
		if (!IS_PRIVATE(mPtr)) {
		    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			    flags);
		}
	    }
	}

     * Return if this is just an entry used to record whether this is a public
     * method. If so, there's nothing real to call and so nothing to add to
     * the call chain.
     *
     * This is also where we enforce mixin-consistency.
     */

    if (!mPtr || !mPtr->typePtr || !MIXIN_CONSISTENT(flags)) {
	return;
    }

    /*
     * Enforce real private method handling here. We will skip adding this
     * method IF
     *  1) we are not allowing private methods, AND
     *  2) this is a private method, AND
     *  3) this is a class method, AND
     *  4) this method was not declared by the class of the current object.
     *
     * This does mean that only classes really handle private methods. This
     * should be sufficient for [incr Tcl] support though.
     */

    if (!WANT_UNEXPORTED(callPtr->flags)
	    && IS_UNEXPORTED(mPtr)
	    && mPtr->declaringClassPtr
	    && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
	return;
    }

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

    Class *contextCls,		/* Context class; the currently considered
				 * class is equal to this, private methods may
				 * also be added. [TIP 500] */
    Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
				 * to be in the same object as the
				 * methodNameObj. */
{
    Foundation *fPtr = oPtr->fPtr;
    CallContext *contextPtr;
    CallChain *callPtr;
    ChainBuilder cb;
    Tcl_Size i, count;
    int doFilters, donePrivate = 0;
    Tcl_HashEntry *hPtr;
    Tcl_HashTable doneFilters;

    if (!cacheInThisObj) {
	cacheInThisObj = methodNameObj;
    }
    if (flags & (SPECIAL | FILTER_HANDLING)
	    || (oPtr->flags & FILTER_HANDLING)) {
	hPtr = NULL;
	doFilters = 0;

	/*
	 * Check if we have a cached valid constructor or destructor.
	 */

	if (flags & CONSTRUCTOR) {
	    callPtr = oPtr->selfCls->constructorChainPtr;
	    if (callPtr
		    && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
		    && (callPtr->epoch == fPtr->epoch)) {
		callPtr->refCount++;
		goto returnContext;
	    }
	} else if (flags & DESTRUCTOR) {
	    callPtr = oPtr->selfCls->destructorChainPtr;
	    if ((oPtr->mixins.num == 0)
		    && callPtr
		    && (callPtr->objectEpoch == oPtr->selfCls->thisPtr->epoch)
		    && (callPtr->epoch == fPtr->epoch)) {
		callPtr->refCount++;
		goto returnContext;
	    }
	}
    } else {
	/*
	 * Check if we can get the chain out of the Tcl_Obj method name or out

	    if (oPtr->selfCls->classChainCache) {
		hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
			methodNameObj);
	    } else {
		hPtr = NULL;
	    }
	} else {
	    if (oPtr->chainCache) {
		hPtr = Tcl_FindHashEntry(oPtr->chainCache,
			methodNameObj);
	    } else {
		hPtr = NULL;
	    }
	}

	if (hPtr && Tcl_GetHashValue(hPtr)) {
	    callPtr = (CallChain *) Tcl_GetHashValue(hPtr);
	    if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
		callPtr->refCount++;
		goto returnContext;
	    }
	    Tcl_SetHashValue(hPtr, NULL);
	    TclOODeleteChain(callPtr);

    /*
     * If we're working with a forced use of unknown, do that now.
     */

    if (flags & FORCE_UNKNOWN) {
	AddSimpleChainToCallContext(oPtr, NULL,
		fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
		NULL);
	AddSimpleChainToCallContext(oPtr, NULL,
		fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = 0;
	if (callPtr->numChain == 0) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
	goto returnContext;

	 */

	if (flags & SPECIAL) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
	AddSimpleChainToCallContext(oPtr, NULL,
		fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
		NULL);
	AddSimpleChainToCallContext(oPtr, NULL,
		fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = 0;
	if (count == callPtr->numChain) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
    } else if (doFilters && !donePrivate) {
	if (!hPtr) {
	    int isNew;
	    if (oPtr->flags & USE_CLASS_CACHE) {
		if (!oPtr->selfCls->classChainCache) {
		    oPtr->selfCls->classChainCache = (Tcl_HashTable *)
			    Tcl_Alloc(sizeof(Tcl_HashTable));

		    Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
		}
		hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
			methodNameObj, &isNew);
	    } else {
		if (!oPtr->chainCache) {
		    oPtr->chainCache = (Tcl_HashTable *)
			    Tcl_Alloc(sizeof(Tcl_HashTable));

		    Tcl_InitObjHashTable(oPtr->chainCache);
		}
		hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
			methodNameObj, &isNew);

	}
	oPtr->selfCls->destructorChainPtr = callPtr;
	callPtr->refCount++;
    }

  returnContext:
    contextPtr = (CallContext *)
	    TclStackAlloc(fPtr->interp, sizeof(CallContext));
    contextPtr->oPtr = oPtr;

    /*
     * Corresponding TclOODecrRefCount() in TclOODeleteContext
     */

    AddRef(oPtr);

    /*
     * Note that it's possible to end up with a NULL clsPtr here if there is
     * a call into stereotypical object after it has finished running its
     * destructor phase. It's quite a tangle, but at that point, we simply
     * can't get stereotypes. [Bug 7842f33a5c]
     */

    if (!clsPtr) {
	return NULL;
    }

    /*
     * Synthesize a temporary stereotypical object so that we can use existing
     * machinery to produce the stereotypical call chain.
     */

    /*
     * Check if we can get the chain out of the Tcl_Obj method name or out of
     * the cache. This is made a bit more complex by the fact that there are
     * multiple different layers of cache (in the Tcl_Obj, in the object, and
     * in the class).
     */

    if (clsPtr->classChainCache) {
	hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
		methodNameObj);
	if (hPtr && Tcl_GetHashValue(hPtr)) {
	    const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);

	    callPtr = (CallChain *) Tcl_GetHashValue(hPtr);
	    if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
		callPtr->refCount++;
		return callPtr;
	    }

	callPtr->flags |= OO_UNKNOWN_METHOD;
	callPtr->epoch = 0;
	if (count == callPtr->numChain) {
	    TclOODeleteChain(callPtr);
	    return NULL;
	}
    } else {
	if (!hPtr) {
	    int isNew;
	    if (!clsPtr->classChainCache) {
		clsPtr->classChainCache = (Tcl_HashTable *)
			Tcl_Alloc(sizeof(Tcl_HashTable));
		Tcl_InitObjHashTable(clsPtr->classChainCache);
	    }
	    hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
		    methodNameObj, &isNew);
	}

    Tcl_Size i;
    int clearedFlags =
	    flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS);
    Class *superPtr, *mixinPtr;
    Tcl_Obj *filterObj;

  tailRecurse:
    if (!clsPtr) {
	return;
    }

    /*
     * Add all the filters defined by classes mixed into the main class
     * hierarchy.
     */

     *
     * Note also that it's possible to end up with a null classPtr here if
     * there is a call into stereotypical object after it has finished running
     * its destructor phase. [Bug 7842f33a5c]
     */

  tailRecurse:
    if (!classPtr) {
	return 0;
    }
    FOREACH(superPtr, classPtr->mixins) {
	if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
		methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
		filterDecl)) {
	    return 1;
	}
    }

    if (classPtr == contextCls) {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		methodName);

	if (hPtr) {
	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);

	    if (IS_PRIVATE(mPtr)) {
		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
			flags);
		return 1;
	    }

     * *and* it is much more gentle on the stack.
     *
     * Note that mixins must be processed before the main class hierarchy.
     * [Bug 1998221]
     */

  tailRecurse:
    if (!classPtr) {
	return privateDanger;
    }
    FOREACH(superPtr, classPtr->mixins) {
	privateDanger |= AddSimpleClassChainToCallContext(superPtr,
		methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
		filterDecl);
    }

    } else {
	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
		methodNameObj);

	if (classPtr->flags & HAS_PRIVATE_METHODS) {
	    privateDanger |= 1;
	}
	if (hPtr) {
	    Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);

	    if (!IS_PRIVATE(mPtr)) {
		if (!(flags & KNOWN_STATE)) {
		    if (flags & PUBLIC_METHOD) {
			if (!IS_PUBLIC(mPtr)) {
			    return privateDanger;

	    callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
	    callPtr->flags & DESTRUCTOR ? fPtr->destructorName :
		    miPtr->mPtr->namePtr;
	descObjs[2] = miPtr->mPtr->declaringClassPtr
		? Tcl_GetObjectName(interp,
			(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
		: objectLiteral;
	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name,
		TCL_AUTO_LENGTH);

	objv[i] = Tcl_NewListObj(4, descObjs);
    }

    /*
     * Drop the local references to the literals; if they're actually used,
     * they'll live on the description itself.

    int i;

    /*
     * Return if this entry is blank. This is also where we enforce
     * mixin-consistency.
     */

    if (!namespaceName || !MIXIN_CONSISTENT(flags)) {
	return;
    }

    /*
     * First test whether the method is already in the call chain.
     */

 */

static inline void
BumpGlobalEpoch(
    Tcl_Interp *interp,
    Class *classPtr)
{
    if (classPtr
	    && classPtr->subclasses.num == 0
	    && classPtr->instances.num == 0
	    && classPtr->mixinSubs.num == 0) {
	/*
	 * If a class has no subclasses or instances, and is not mixed into
	 * anything, a change to its structure does not require us to
	 * invalidate any call chains. Note that we still bump our object's

 * ----------------------------------------------------------------------
 */

static inline void
RecomputeClassCacheFlag(
    Object *oPtr)
{
    if ((!oPtr->methodsPtr || oPtr->methodsPtr->numEntries == 0)
	    && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) {
	oPtr->flags |= USE_CLASS_CACHE;
    } else {
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
}


	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "method %s does not exist", TclGetString(fromPtr)));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		    TclGetString(fromPtr), (char *)NULL);
	    return TCL_ERROR;
	}
	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, fromPtr);
	if (!hPtr) {
	    goto noSuchMethod;
	}
	if (toPtr) {
	    newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr,
		    &isNew);
	    if (hPtr == newHPtr) {
	    renameToSelf:
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"cannot rename method to itself", TCL_AUTO_LENGTH));
		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", (char *)NULL);
		return TCL_ERROR;
	    } else if (!isNew) {
	    renameToExisting:
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"method called %s already exists",
			TclGetString(toPtr)));
		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", (char *)NULL);
		return TCL_ERROR;
	    }
	}
    } else {
	hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, fromPtr);
	if (!hPtr) {
	    goto noSuchMethod;
	}
	if (toPtr) {
	    newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods,
		    (char *) toPtr, &isNew);
	    if (hPtr == newHPtr) {
		goto renameToSelf;

    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    Tcl_Size soughtLen;
    const char *soughtStr, *matchedStr = NULL;

    if (objc < 2) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"bad call of unknown handler", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (char *)NULL);
	return TCL_ERROR;
    }
    if (!TclOOGetDefineCmdContext(interp)) {
	return TCL_ERROR;
    }

    soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
    if (soughtLen == 0) {
	goto noMatch;
    }
    hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
    while (hPtr) {
	const char *nameStr = (const char *)
		Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);

	if (!strncmp(soughtStr, nameStr, soughtLen)) {
	    if (matchedStr) {
		goto noMatch;
	    }
	    matchedStr = nameStr;
	}
	hPtr = Tcl_NextHashEntry(&search);
    }

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

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

	newObjv[0] = Tcl_NewStringObj(matchedStr, TCL_AUTO_LENGTH);
	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);

    FOREACH_HASH_DECLS;
    Tcl_Command cmd, cmd2;

    /*
     * If someone is playing games, we stop playing right now.
     */

    if (string[0] == '\0' || strstr(string, "::")) {
	return NULL;
    }

    /*
     * Do the exact lookup first.
     */

    cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY);
    if (cmd) {
	return cmd;
    }

    /*
     * Bother, need to perform an approximate match. Iterate across the hash
     * table of commands in the namespace.
     */

    FOREACH_HASH(nameStr, cmd2, &nsPtr->cmdTable) {
	if (!strncmp(string, nameStr, length)) {
	    if (cmd) {
		return NULL;
	    }
	    cmd = cmd2;
	}
    }

    /*

    Tcl_Namespace *namespacePtr,
    Object *oPtr,
    int objc,
    Tcl_Obj *const objv[])
{
    CallFrame *framePtr, **framePtrPtr = &framePtr;

    if (!namespacePtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"no definition namespace available", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
     */

Tcl_Object
TclOOGetDefineCmdContext(
    Tcl_Interp *interp)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Object object;

    if (!iPtr->varFramePtr
	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
	    && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command may only be called from within the context of"
		" an ::oo::define or ::oo::objdefine command", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return NULL;
    }
    object = (Tcl_Object) iPtr->varFramePtr->clientData;
    if (Tcl_ObjectDeleted(object)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"this command cannot be called when the object has been"
		" deleted", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return NULL;
    }
    return object;
}

Class *
TclOOGetClassDefineCmdContext(
    Tcl_Interp *interp)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return NULL;
    }
    if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return NULL;
    }
    return oPtr->classPtr;
}

/*

{
    Interp *iPtr = (Interp *) interp;
    Object *oPtr;
    CallFrame *savedFramePtr = iPtr->varFramePtr;

    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
	    || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
	if (!iPtr->varFramePtr->callerVarPtr) {
	    Tcl_Panic("getting outer context when already in global context");
	}
	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
    iPtr->varFramePtr = savedFramePtr;
    if (!oPtr) {
	return NULL;
    }
    if (!oPtr->classPtr) {
	if (errMsg) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		    TclGetString(className), (char *)NULL);
	}
	return NULL;
    }
    return oPtr->classPtr;
}

static inline Tcl_Namespace *
GetNamespaceInOuterContext(
    Tcl_Interp *interp,
    Tcl_Obj *namespaceName)
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Namespace *nsPtr;
    int result;
    CallFrame *savedFramePtr = iPtr->varFramePtr;

    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
	    || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
	if (!iPtr->varFramePtr->callerVarPtr) {
	    Tcl_Panic("getting outer context when already in global context");
	}
	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
    }
    result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr);
    iPtr->varFramePtr = savedFramePtr;
    if (result != TCL_OK) {

     * Build the list of arguments using a Tcl_Obj as a workspace. See
     * comments above for why these contortions are necessary.
     */

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

	Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]);
    } else {
	Tcl_GetCommandFullName(interp, cmd, obj2Ptr);

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"%s does not refer to a class", TclGetString(objv[1])));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		TclGetString(objv[1]), (char *)NULL);
	return TCL_ERROR;
    }

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    /*
     * Make the oo::objdefine namespace the current namespace and evaluate the
     * command(s).
     */

    Tcl_Obj *const *objv)
{
    Tcl_Namespace *nsPtr;
    Object *oPtr;
    int result, isPrivate;

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }

    if (objc < 2) {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
	return TCL_OK;
    }

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

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
    return TCL_OK;
}


    Interp *iPtr = (Interp *) interp;
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int saved;			/* The saved flag. We restore it on exit so
				 * that [private private ...] doesn't make
				 * things go weird. */
    int result;

    if (!oPtr) {
	return TCL_ERROR;
    }
    if (objc == 1) {
	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp)));
	return TCL_OK;
    }

    int wasClass, willBeClass;

    /*
     * Parse the context to get the object to operate on.
     */

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_OBJECT) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the root object class",
		TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }
    if (oPtr->flags & ROOT_CLASS) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the class of the class of classes",
		TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Parse the argument to get the class to set the object's class to.
     */

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = GetClassInOuterContext(interp, objv[1],
	    "the class of an object must be a class");
    if (!clsPtr) {
	return TCL_ERROR;
    }
    if (oPtr == clsPtr->thisPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not change classes into an instance of themselves",
		TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Set the object's class.
     */

	if (wasClass && !willBeClass) {
	    /*
	     * This is the most global of all epochs. Bump it! No cache can be
	     * trusted!
	     */

	    TclOORemoveFromMixins(oPtr->classPtr, oPtr);
	    GetFoundation(interp)->epoch++;
	    oPtr->flags |= DONT_DELETE;
	    TclOODeleteDescendants(interp, oPtr);
	    oPtr->flags &= ~DONT_DELETE;
	    TclOOReleaseClassContents(interp, oPtr);
	    Tcl_Free(oPtr->classPtr);
	    oPtr->classPtr = NULL;
	} else if (!wasClass && willBeClass) {
	    TclOOAllocClass(interp, oPtr);
	}

	if (oPtr->classPtr) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    BumpInstanceEpoch(oPtr);
	}
    }
    return TCL_OK;
}

    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Method method;
    Tcl_Size bodyLength;

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
	return TCL_ERROR;
    }

    (void) TclGetStringFromObj(objv[2], &bodyLength);
    if (bodyLength > 0) {
	/*
	 * Create the method structure.
	 */

	method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
		PUBLIC_METHOD, NULL, objv[1], objv[2], NULL);
	if (!method) {
	    return TCL_ERROR;
	}
    } else {
	/*
	 * Delete the constructor method record and set the field in the
	 * class record to NULL.
	 */

	NULL
    };
    int kind = 0;
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Namespace *nsPtr;
    Tcl_Obj *nsNamePtr, **storagePtr;

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (clsPtr->thisPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the definition namespace of the root classes",
		TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Parse the arguments and work out what the user wants to do.
     */

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace");
	return TCL_ERROR;
    }
    if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0,
	    &kind) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!TclGetString(objv[objc - 1])[0]) {
	nsNamePtr = NULL;
    } else {
	nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
	if (!nsPtr) {
	    return TCL_ERROR;
	}
	nsNamePtr = TclNewNamespaceObj(nsPtr);
	Tcl_IncrRefCount(nsNamePtr);
    }

    /*
     * Update the correct field of the class definition.
     */

    if (kind) {
	storagePtr = &clsPtr->objDefinitionNs;
    } else {
	storagePtr = &clsPtr->clsDefinitionNs;
    }
    if (*storagePtr) {
	Tcl_DecrRefCount(*storagePtr);
    }
    *storagePtr = nsNamePtr;
    return TCL_OK;
}

/*

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

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

    int objc,
    Tcl_Obj *const *objv)
{
    Tcl_Method method;
    Tcl_Size bodyLength;
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);

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


    (void) TclGetStringFromObj(objv[1], &bodyLength);
    if (bodyLength > 0) {
	/*
	 * Create the method structure.
	 */

	method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
		PUBLIC_METHOD, NULL, NULL, objv[1], NULL);
	if (!method) {
	    return TCL_ERROR;
	}
    } else {
	/*
	 * Delete the destructor method record and set the field in the class
	 * record to NULL.
	 */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceExport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Exporting is done by adding the PUBLIC_METHOD flag to the method

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (!isInstanceForward && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }
    isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN)
	    ? PUBLIC_METHOD : 0;
    if (IsPrivateDefine(interp)) {
	isPublic = TRUE_PRIVATE_METHOD;

    if (isInstanceForward) {
	mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
		prefixObj);
    } else {
	mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
		objv[1], prefixObj);
    }
    if (!mPtr) {
	Tcl_DecrRefCount(prefixObj);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*

    if (objc < 4 || objc > 5) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body");
	return TCL_ERROR;
    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (!isInstanceMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }
    if (objc == 5) {
	if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag",
		0, &exportMode) != TCL_OK) {
	    return TCL_ERROR;

    }

    /*
     * Create the method by using the right back-end API.
     */

    if (isInstanceMethod) {
	if (!TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
		objv[objc - 2], objv[objc - 1], NULL)) {
	    return TCL_ERROR;
	}
    } else {
	if (!TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
		objv[objc - 2], objv[objc - 1], NULL)) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

/*

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
	return TCL_ERROR;
    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (!isInstanceRenameMethod && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Delete the method entry from the appropriate hash table, and transfer
     * the thing it points to to its new entry. To do this, we first need to

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
	return TCL_ERROR;
    }

    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    if (!oPtr) {
	return TCL_ERROR;
    }
    clsPtr = oPtr->classPtr;
    if (!isInstanceUnexport && !clsPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	/*
	 * Unexporting is done by removing the PUBLIC_METHOD flag from the

    const DeclaredSlot *slotInfoPtr;
    Tcl_Interp *interp = fPtr->interp;
    Tcl_Obj *getName, *setName, *resolveName;
    Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class)
	    fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0);
    Class *slotCls;

    if (!object) {
	return TCL_ERROR;
    }
    slotCls = ((Object *) object)->classPtr;
    if (!slotCls) {
	return TCL_ERROR;
    }

    TclNewLiteralStringObj(getName, "Get");
    TclNewLiteralStringObj(setName, "Set");
    TclNewLiteralStringObj(resolveName, "Resolve");
    for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
	Tcl_Object slotObject = Tcl_NewObjectInstance(interp,
		(Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE,
		NULL, 0);

	if (!slotObject) {
	    continue;
	}
	TclNewInstanceMethod(interp, slotObject, getName, 0,
		&slotInfoPtr->getterType, NULL);
	TclNewInstanceMethod(interp, slotObject, setName, 0,
		&slotInfoPtr->setterType, NULL);
	if (slotInfoPtr->resolverType.callProc) {

    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Obj *resultObj, *filterObj;
    Tcl_Size i;

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Size filterc;
    Tcl_Obj **filterv;

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

    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *mixinPtr;
    Tcl_Size i;

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

    Class **mixins;		/* The references to the classes to actually
				 * install. */
    Tcl_HashTable uniqueCheck;	/* Note that this hash table is just used as a
				 * set of class references; it has no payload
				 * values and keys are always pointers. */
    int isNew;

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

    if (TclListObjGetElements(interp, objv[0], &mixinc, &mixinv) != TCL_OK) {
	return TCL_ERROR;
    }

    mixins = (Class **) TclStackAlloc(interp, sizeof(Class *) * mixinc);
    Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (!mixins[i]) {
	    i--;
	    goto freeAndError;
	}
	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "class should only be a direct mixin once",
		    TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", (char *)NULL);
	    goto freeAndError;
	}
	if (TclOOIsReachable(clsPtr, mixins[i])) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "may not mix a class into itself", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (char *)NULL);
	    goto freeAndError;
	}
    }

    TclOOClassSetMixins(interp, clsPtr, mixinc, mixins);
    Tcl_DeleteHashTable(&uniqueCheck);

    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Class *superPtr;
    Tcl_Size i;

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Size superc, j;
    Tcl_Size i;
    Tcl_Obj **superv;
    Class **superclasses, *superPtr;

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

    Foundation *fPtr = GetFoundation(interp);
    if (clsPtr == fPtr->objectCls) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"may not modify the superclass of the root object",
		TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    } else if (TclListObjGetElements(interp, objv[0], &superc,
	    &superv) != TCL_OK) {
	return TCL_ERROR;
    }

	}
	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]) {
		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",
			    TCL_AUTO_LENGTH));
		    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",(char *)NULL);
		    goto failedAfterAlloc;
		}
	    }
	    if (TclOOIsReachable(clsPtr, superclasses[i])) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"attempt to form circular dependency graph",
			TCL_AUTO_LENGTH));
		Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (char *)NULL);
	    failedAfterAlloc:
		for (; i-- > 0 ;) {
		    TclOODecrRefCount(superclasses[i]->thisPtr);
		}
		Tcl_Free(superclasses);
		return TCL_ERROR;

    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Size i;
    Tcl_Size varc;
    Tcl_Obj **varv;

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

    if (TclListObjGetElements(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, "::")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (char *)NULL);
	    return TCL_ERROR;
	}
	if (Tcl_StringMatch(varName, "*(*)")) {

    Tcl_Obj *resultObj, *filterObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (!oPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(filterObj, oPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
    }

    Tcl_Size filterc;
    Tcl_Obj **filterv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    } else if (!oPtr) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (TclListObjGetElements(interp, objv[0], &filterc, &filterv) != TCL_OK) {
	return TCL_ERROR;
    }

    Class *mixinPtr;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (!oPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(mixinPtr, oPtr->mixins) {
	if (mixinPtr) {
	    Tcl_ListObjAppendElement(NULL, resultObj,

				 * values and keys are always pointers. */
    int isNew;

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

    mixins = (Class **) TclStackAlloc(interp, sizeof(Class *) * mixinc);
    Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);

    for (i = 0; i < mixinc; i++) {
	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
		"may only mix in classes");
	if (!mixins[i]) {
	    goto freeAndError;
	}
	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
	if (!isNew) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "class should only be a direct mixin once", TCL_AUTO_LENGTH));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", (char *)NULL);
	    goto freeAndError;
	}
    }

    TclOOObjectSetMixins(oPtr, mixinc, mixins);
    TclStackFree(interp, mixins);

    Tcl_Obj *resultObj;
    Tcl_Size i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    } else if (!oPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    if (IsPrivateDefine(interp)) {
	PrivateVariableMapping *privatePtr;

    Tcl_Size 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) {
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);
    if (TclListObjGetElements(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, "::")) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "invalid declared variable name \"%s\": must not %s",
		    varName, "contain namespace separators"));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (char *)NULL);
	    return TCL_ERROR;
	}
	if (Tcl_StringMatch(varName, "*(*)")) {

    Class *clsPtr;

    /*
     * Check if were called wrongly. The definition context isn't used...
     * except that GetClassInOuterContext() assumes that it is there.
     */

    if (!oPtr) {
	return TCL_ERROR;
    } else if (objc != idx + 1) {
	Tcl_WrongNumArgs(interp, idx, objv, "slotElement");
	return TCL_ERROR;
    }

    /*
     * Resolve the class if possible. If not, remove any resolution error and
     * return what we've got anyway as the failure might not be fatal overall.
     */

    clsPtr = GetClassInOuterContext(interp, objv[idx], NULL);

    if (!clsPtr) {
	Tcl_ResetResult(interp);
	Tcl_SetObjResult(interp, objv[idx]);
    } else {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
    }

    return TCL_OK;

    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Size varc;
    Tcl_Obj **varv;

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

    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);

    if (!oPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

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

    if (!oPtr) {
	return TCL_ERROR;
    } else if (TclListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    TclOOInstallReadableProperties(&oPtr->properties, varc, varv);

    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);

    if (!clsPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

    int objc,
    Tcl_Obj *const *objv)
{
    Class *clsPtr = TclOOGetClassDefineCmdContext(interp);
    Tcl_Size varc;
    Tcl_Obj **varv;

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

    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);

    if (!oPtr) {
	return TCL_ERROR;
    } else if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }

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

    if (!oPtr) {
	return TCL_ERROR;
    } else if (TclListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    TclOOInstallWritableProperties(&oPtr->properties, varc, varv);

Class *
TclOOGetClassFromObj(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr)
{
    Object *oPtr = (Object *) Tcl_GetObjectFromObj(interp, objPtr);

    if (!oPtr) {
	return NULL;
    }
    if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"\"%s\" is not a class", TclGetString(objPtr)));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
		TclGetString(objPtr), (char *)NULL);
	return NULL;
    }
    return oPtr->classPtr;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?className?");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    if (objc == 2) {
	Tcl_SetObjResult(interp,
		TclOOObjectName(interp, oPtr->selfCls->thisPtr));
	return TCL_OK;
    } else {
	Class *mixinPtr, *o2clsPtr;
	Tcl_Size i;

	o2clsPtr = TclOOGetClassFromObj(interp, objv[2]);
	if (!o2clsPtr) {
	    return TCL_ERROR;
	}

	FOREACH(mixinPtr, oPtr->mixins) {
	    if (!mixinPtr) {
		continue;
	    }

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    if (!oPtr->methodsPtr) {
	goto unknownMethod;
    }
    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
    if (!hPtr) {
	goto unknownMethod;
    }
    procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr));
    if (!procPtr) {
	goto wrongType;
    }

    /*
     * We now have the method to describe the definition of.
     */

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
	    if (localPtr->defValuePtr) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr));
    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));

	    "unknown method \"%s\"", TclGetString(objv[2])));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[2]), (char *)NULL);
    return TCL_ERROR;

  wrongType:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "definition not available for this kind of method", TCL_AUTO_LENGTH));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[2]), (char *)NULL);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------

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

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }
    TclNewObj(resultObj);

    FOREACH(filterObj, oPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
    }

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    if (!oPtr->methodsPtr) {
	goto unknownMethod;
    }
    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
    if (!hPtr) {
	goto unknownMethod;
    }
    prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr));
    if (!prefixObj) {
	goto wrongType;
    }

    /*
     * Describe the valid forward method.
     */

    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[2]), (char *)NULL);
    return TCL_ERROR;

  wrongType:
    Tcl_SetObjResult(interp, Tcl_NewStringObj(
	    "prefix argument list not available for this kind of method",
	    TCL_AUTO_LENGTH));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[2]), (char *)NULL);
    return TCL_ERROR;
}

/*
 * ----------------------------------------------------------------------

    /*
     * Perform the check. Note that we can guarantee that we will not fail
     * from here on; "failures" result in a false-TCL_OK result.
     */

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
    if (!oPtr) {
	goto failPrecondition;
    }

    switch (idx) {
    case IsObject:
	result = 1;
	break;
    case IsClass:
	result = (oPtr->classPtr != NULL);
	break;
    case IsMetaclass:
	if (oPtr->classPtr) {
	    result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls,
		    oPtr->classPtr);
	}
	break;
    case IsMixin:
	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
	if (!o2Ptr) {
	    goto failPrecondition;
	}
	if (o2Ptr->classPtr) {
	    Class *mixinPtr;

	    FOREACH(mixinPtr, oPtr->mixins) {
		if (!mixinPtr) {
		    continue;
		}
		if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
		    result = 1;
		    break;
		}
	    }
	}
	break;
    case IsType:
	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]);
	if (!o2Ptr) {
	    goto failPrecondition;
	}
	if (o2Ptr->classPtr) {
	    result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls);
	}
	break;
    }
    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
    return TCL_OK;

static int
InfoObjectMethodsCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{





    static const char *const options[] = {
	"-all", "-localprivate", "-private", "-scope", NULL
    };
    enum Options {
	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
    } idx;
    static const char *const scopes[] = {
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
	SCOPE_LOCALPRIVATE,
	UNSCOPED = -1		// No scope given; legacy mode
    };
    Object *oPtr;
    int flag = PUBLIC_METHOD, recurse = 0, scope = UNSCOPED;
    FOREACH_HASH_DECLS;
    Tcl_Obj *namePtr, *resultObj;
    Method *mPtr;

    /*
     * Parse arguments.
     */

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (objc != 2) {
	int i;

	for (i=2 ; i<objc ; i++) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,

			&scope) != TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    }
	}
    }
    if (scope != UNSCOPED) {
	recurse = 0;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;

    if (recurse) {
	const char **names;
	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
		&names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], TCL_AUTO_LENGTH));
	}
	if (numNames > 0) {
	    Tcl_Free((void *) names);
	}
    } else if (oPtr->methodsPtr) {
	if (scope == UNSCOPED) {
	    /*
	     * Handle legacy-mode matching. [Bug 36e5517a6850]
	     */
	    int scopeFilter = flag | TRUE_PRIVATE_METHOD;

	    FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
		if (mPtr->typePtr && (mPtr->flags & scopeFilter) == flag) {

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
	return TCL_ERROR;
    }

    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    if (!oPtr->methodsPtr) {
	goto unknownMethod;
    }
    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]);
    if (!hPtr) {
	goto unknownMethod;
    }
    mPtr = (Method *) Tcl_GetHashValue(hPtr);
    if (!mPtr->typePtr) {
	/*
	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }

    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, TCL_AUTO_LENGTH));
    return TCL_OK;

  unknownMethod:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "unknown method \"%s\"", TclGetString(objv[2])));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[2]), (char *)NULL);

    Tcl_Size i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(mixinPtr, oPtr->mixins) {
	if (!mixinPtr) {
	    continue;

    Object *oPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oPtr->creationEpoch));
    return TCL_OK;
}


    Object *oPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, TclNewNamespaceObj(oPtr->namespacePtr));
    return TCL_OK;
}


		    TclGetString(objv[2])));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_ARG");
	    return TCL_ERROR;
	}
	isPrivate = 1;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    if (isPrivate) {
	PrivateVariableMapping *privatePtr;

    Tcl_Obj *nameObj, *resultObj;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?pattern?");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }
    if (objc == 3) {
	pattern = TclGetString(objv[2]);
    }
    TclNewObj(resultObj);

	    &((Namespace *) oPtr->namespacePtr)->varTable.table) {
	nameObj = vihPtr->entry.key.objPtr;

	if (TclIsVarUndefined(&vihPtr->var)
		|| !TclIsVarNamespaceVar(&vihPtr->var)) {
	    continue;
	}

	if (pattern && !Tcl_StringMatch(TclGetString(nameObj), pattern)) {
	    continue;
	}
	Tcl_ListObjAppendElement(NULL, resultObj, nameObj);
    }

    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

    Class *clsPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    if (!clsPtr->constructorPtr) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->constructorPtr);
    if (!procPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
	    if (localPtr->defValuePtr) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr);
    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));

    Class *clsPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
    if (!hPtr) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"unknown method \"%s\"", TclGetString(objv[2])));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }
    procPtr = TclOOGetProcFromMethod((Method *) Tcl_GetHashValue(hPtr));
    if (!procPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }

    TclNewObj(resultObjs[0]);
    for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr));
	    if (localPtr->defValuePtr) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
	}
    }
    resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr));
    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));

    Class *clsPtr;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0,
	    &kind) != TCL_OK) {
	return TCL_ERROR;
    }

    Class *clsPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    if (!clsPtr->destructorPtr) {
	return TCL_OK;
    }
    procPtr = TclOOGetProcFromMethod(clsPtr->destructorPtr);
    if (!procPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"definition not available for this kind of method", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", (char *)NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, TclOOGetMethodBody(clsPtr->destructorPtr));
    return TCL_OK;
}

    Class *clsPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(filterObj, clsPtr->filters) {
	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
    }

    Class *clsPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
    if (!hPtr) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"unknown method \"%s\"", TclGetString(objv[2])));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }
    prefixObj = TclOOGetFwdFromMethod((Method *) Tcl_GetHashValue(hPtr));
    if (!prefixObj) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"prefix argument list not available for this kind of method",
		TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
		TclGetString(objv[2]), (char *)NULL);
	return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, prefixObj);
    return TCL_OK;

    Tcl_Obj *resultObj;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    if (objc == 3) {
	pattern = TclGetString(objv[2]);
    }

    TclNewObj(resultObj);

static int
InfoClassMethodsCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{




    static const char *const options[] = {
	"-all", "-localprivate", "-private", "-scope", NULL
    };
    enum Options {
	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
    } idx;
    static const char *const scopes[] = {
	"private", "public", "unexported"
    };
    enum Scopes {
	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
	UNSCOPED = -1		// No scope given; legacy mode
    };
    int flag = PUBLIC_METHOD, recurse = 0, scope = UNSCOPED;
    Tcl_Obj *namePtr, *resultObj;
    Method *mPtr;
    Class *clsPtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    if (objc != 2) {
	int i;

	for (i=2 ; i<objc ; i++) {
	    if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,

			&scope) != TCL_OK) {
		    return TCL_ERROR;
		}
		break;
	    }
	}
    }
    if (scope != UNSCOPED) {
	recurse = 0;
	switch (scope) {
	case SCOPE_PRIVATE:
	    flag = TRUE_PRIVATE_METHOD;
	    break;
	case SCOPE_PUBLIC:
	    flag = PUBLIC_METHOD;

    TclNewObj(resultObj);
    if (recurse) {
	const char **names;
	Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);

	for (i=0 ; i<numNames ; i++) {
	    Tcl_ListObjAppendElement(NULL, resultObj,
		    Tcl_NewStringObj(names[i], TCL_AUTO_LENGTH));
	}
	if (numNames > 0) {
	    Tcl_Free((void *) names);
	}
    } else {
	FOREACH_HASH_DECLS;

	if (scope == UNSCOPED) {
	    /*
	     * Handle legacy-mode matching. [Bug 36e5517a6850]
	     */
	    int scopeFilter = flag | TRUE_PRIVATE_METHOD;

	    FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
		if (mPtr->typePtr && (mPtr->flags & scopeFilter) == flag) {

    Class *clsPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]);
    if (!hPtr) {
	goto unknownMethod;
    }
    mPtr = (Method *) Tcl_GetHashValue(hPtr);
    if (!mPtr->typePtr) {
	/*
	 * Special entry for visibility control: pretend the method doesnt
	 * exist.
	 */

	goto unknownMethod;
    }
    Tcl_SetObjResult(interp, Tcl_NewStringObj(mPtr->typePtr->name, TCL_AUTO_LENGTH));
    return TCL_OK;

  unknownMethod:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "unknown method \"%s\"", TclGetString(objv[2])));
    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
	    TclGetString(objv[2]), (char *)NULL);

    Tcl_Size i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(mixinPtr, clsPtr->mixins) {
	if (!mixinPtr) {
	    continue;

    const char *pattern = NULL;

    if (objc != 2 && objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?pattern?");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    if (objc == 3) {
	pattern = TclGetString(objv[2]);
    }

    TclNewObj(resultObj);

    Tcl_Size i;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    FOREACH(superPtr, clsPtr->superclasses) {
	Tcl_ListObjAppendElement(NULL, resultObj,
		TclOOObjectName(interp, superPtr->thisPtr));

		    TclGetString(objv[2])));
	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_ARG");
	    return TCL_ERROR;
	}
	isPrivate = 1;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    TclNewObj(resultObj);
    if (isPrivate) {
	PrivateVariableMapping *privatePtr;

    CallContext *contextPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }

    /*
     * Get the call context and render its call chain.
     */

    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
	    NULL);
    if (!contextPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_CALL_CHAIN");
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp,
	    TclOORenderCallChain(interp, contextPtr->callPtr));
    TclOODeleteContext(contextPtr);
    return TCL_OK;

    CallChain *callPtr;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }

    /*
     * Get an render the stereotypical call chain.
     */

    callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
    if (!callPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"cannot construct any call chain", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_CALL_CHAIN");
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    TclOODeleteChain(callPtr);
    return TCL_OK;
}

				 * destructor. */
    Tcl_Obj *clonedName;	/* Shared object containing the name of a
				 * "<cloned>" pseudo-constructor. */
    Tcl_Obj *defineName;	/* Fully qualified name of oo::define. */
    Tcl_Obj *myName;		/* The "my" shared object. */
};

/*
 * Convenience macro for getting the foundation from an interpreter.
 */

#define GetFoundation(interp) \
	((Foundation *)((Interp *)(interp))->objectFoundation)

/*
 * The number of MInvoke records in the CallChain before we allocate
 * separately.
 */
#define CALL_CHAIN_STATIC_SIZE 4

/*

				 * method to be created. */
{
    Object *oPtr = (Object *) object;
    Method *mPtr;
    Tcl_HashEntry *hPtr;
    int isNew;

    if (!nameObj) {
	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
	mPtr->namePtr = NULL;
	mPtr->refCount = 1;
	goto populate;
    }
    if (!oPtr->methodsPtr) {
	oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable));
	Tcl_InitObjHashTable(oPtr->methodsPtr);
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
    hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, nameObj, &isNew);
    if (isNew) {
	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
	mPtr->namePtr = nameObj;
	mPtr->refCount = 1;
	Tcl_IncrRefCount(nameObj);
	Tcl_SetHashValue(hPtr, mPtr);
    } else {
	mPtr = (Method *) Tcl_GetHashValue(hPtr);
	if (mPtr->typePtr && mPtr->typePtr->deleteProc) {
	    mPtr->typePtr->deleteProc(mPtr->clientData);
	}
    }

  populate:
    mPtr->typePtr = typePtr;
    mPtr->clientData = clientData;

				 * method to be created. */
{
    Class *clsPtr = (Class *) cls;
    Method *mPtr;
    Tcl_HashEntry *hPtr;
    int isNew;

    if (!nameObj) {
	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
	mPtr->namePtr = NULL;
	mPtr->refCount = 1;
	goto populate;
    }
    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj, &isNew);
    if (isNew) {
	mPtr = (Method *) Tcl_Alloc(sizeof(Method));
	mPtr->refCount = 1;
	mPtr->namePtr = nameObj;
	Tcl_IncrRefCount(nameObj);
	Tcl_SetHashValue(hPtr, mPtr);
    } else {
	mPtr = (Method *) Tcl_GetHashValue(hPtr);
	if (mPtr->typePtr && mPtr->typePtr->deleteProc) {
	    mPtr->typePtr->deleteProc(mPtr->clientData);
	}
    }

  populate:
    clsPtr->thisPtr->fPtr->epoch++;
    mPtr->typePtr = typePtr;

 * ----------------------------------------------------------------------
 */

void
TclOODelMethodRef(
    Method *mPtr)
{
    if (mPtr && (mPtr->refCount-- <= 1)) {
	if (mPtr->typePtr && mPtr->typePtr->deleteProc) {
	    mPtr->typePtr->deleteProc(mPtr->clientData);
	}
	if (mPtr->namePtr) {
	    Tcl_DecrRefCount(mPtr->namePtr);
	}

	Tcl_Free(mPtr);
    }
}


void
TclOONewBasicMethod(
    Class *clsPtr,		/* Class to attach the method to. */
    const DeclaredClassMethod *dcm)
				/* Name of the method, whether it is public,
				 * and the function to implement it. */
{
    Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, TCL_AUTO_LENGTH);

    TclNewMethod((Tcl_Class) clsPtr, namePtr,
	    (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL);
    Tcl_BounceRefCount(namePtr);
}

/*

    if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
	return NULL;
    }
    pmPtr = AllocProcedureMethodRecord(flags);
    method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
	    argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
    if (!method) {
	Tcl_Free(pmPtr);
    } else if (pmPtrPtr) {
	*pmPtrPtr = pmPtr;
    }
    return (Method *) method;
}

/*
 * ----------------------------------------------------------------------

				 * interested. */
{
    Tcl_Size argsLen;		/* TCL_INDEX_NONE => delete argsObj before exit */
    ProcedureMethod *pmPtr;
    const char *procName;
    Tcl_Method method;

    if (!argsObj) {
	argsLen = TCL_INDEX_NONE;
	TclNewObj(argsObj);
	Tcl_IncrRefCount(argsObj);
	procName = "<destructor>";
    } else if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
	return NULL;
    } else {
	procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
    }

    pmPtr = AllocProcedureMethodRecord(flags);
    method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
	    argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);

    if (argsLen == TCL_INDEX_NONE) {
	Tcl_DecrRefCount(argsObj);
    }
    if (!method) {
	Tcl_Free(pmPtr);
    } else if (pmPtrPtr) {
	*pmPtrPtr = pmPtr;
    }

    return (Method *) method;
}

/*

	pmPtr->efi.fields[0].name = "method";
	pmPtr->efi.fields[0].proc = RenderMethodName;
	pmPtr->efi.fields[0].clientData = pmPtr;
	pmPtr->callSiteFlags = ((CallContext *)
		context)->callPtr->flags & (CONSTRUCTOR | DESTRUCTOR);
	pmPtr->interp = interp;
	pmPtr->method = method;
	if (pmPtr->gfivProc) {
	    pmPtr->efi.fields[1].name = "";
	    pmPtr->efi.fields[1].proc = pmPtr->gfivProc;
	    pmPtr->efi.fields[1].clientData = pmPtr;
	} else {
	    if (Tcl_MethodDeclarerObject(method)) {
		pmPtr->efi.fields[1].name = "object";
	    } else {
		pmPtr->efi.fields[1].name = "class";
	    }
	    pmPtr->efi.fields[1].proc = RenderDeclarerName;
	    pmPtr->efi.fields[1].clientData = pmPtr;
	}

    pmPtr->refCount++;

    /*
     * Give the pre-call callback a chance to do some setup and, possibly,
     * veto the call.
     */

    if (pmPtr->preCallProc) {
	int isFinished;

	result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
		(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
	if (isFinished || result != TCL_OK) {
	    Tcl_PopCallFrame(interp);
	    TclStackFree(interp, fdPtr->framePtr);

				 * method. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv,	/* Array of arguments. */
    PMFrameData *fdPtr)		/* Place to store information about the call
				 * frame. */
{
    Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
    Foundation *fPtr = GetFoundation(interp);
    int result;
    CallFrame **framePtrPtr = &fdPtr->framePtr;
    ByteCode *codePtr;

    /*
     * Compute basic information on the basis of the type of method it is.
     */

    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	fdPtr->nameObj = fPtr->constructorName;
	fdPtr->errProc = ConstructorErrorHandler;
    } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
	fdPtr->nameObj = fPtr->destructorName;
	fdPtr->errProc = DestructorErrorHandler;
    } else {
	fdPtr->nameObj = Tcl_MethodName(
		Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr));
	fdPtr->errProc = MethodErrorHandler;
    }
    if (pmPtr->errProc) {
	fdPtr->errProc = pmPtr->errProc;
    }

    /*
     * Magic to enable things like [incr Tcl], which wants methods to run in
     * their class's namespace.
     */

    if (pmPtr->flags & USE_DECLARER_NS) {
	Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;

	if (mPtr->declaringClassPtr) {
	    nsPtr = (Namespace *)
		    mPtr->declaringClassPtr->thisPtr->namespacePtr;
	} else {
	    nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr;
	}
    }

void
TclOOSetupVariableResolver(
    Tcl_Namespace *nsPtr)
{
    Tcl_ResolverInfo info;

    Tcl_GetNamespaceResolvers(nsPtr, &info);
    if (!info.compiledVarResProc) {
	Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver,
		ProcedureMethodCompiledVarResolver);
    }
}

static int
ProcedureMethodVarResolver(

    /*
     * Check that the variable is being requested in a context that is also a
     * method call; if not (i.e. we're evaluating in the object's namespace or
     * in a procedure of that namespace) then we do nothing.
     */

    if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
	return NULL;
    }
    contextPtr = (CallContext *) framePtr->clientData;

    /*
     * If we've done the work before (in a comparable context) then reuse that
     * rather than performing resolution ourselves.
     */

    if (infoPtr->cachedObjectVar) {
	return infoPtr->cachedObjectVar;
    }

    /*
     * Check if the variable is one we want to resolve at all (i.e. whether it
     * is in the list provided by the user). If not, we mustn't do anything
     * either.
     */

    varName = Tcl_GetStringFromObj(infoPtr->variableObj, &varLen);
    if (contextPtr->callPtr->chain[contextPtr->index].mPtr->declaringClassPtr) {

	FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
		.mPtr->declaringClassPtr->privateVariables) {
	    match = Tcl_GetStringFromObj(privateVar->variableObj, &len);
	    if ((len == varLen) && !memcmp(match, varName, len)) {
		variableObj = privateVar->fullNameObj;
		cacheIt = 0;
		goto gotMatch;

    Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);

    /*
     * Do not create resolvers for cases that contain namespace separators or
     * which look like array accesses. Both will lead us astray.
     */

    if (strstr(TclGetString(variableObj), "::") ||
	    Tcl_StringMatch(TclGetString(variableObj), "*(*)")) {
	Tcl_DecrRefCount(variableObj);
	return TCL_CONTINUE;
    }

    infoPtr = (OOResVarInfo *) Tcl_Alloc(sizeof(OOResVarInfo));
    infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;

static Tcl_Obj *
RenderDeclarerName(
    void *clientData)
{
    ProcedureMethod *pmPtr = (ProcedureMethod *) clientData;
    Tcl_Object object = Tcl_MethodDeclarerObject(pmPtr->method);

    if (!object) {
	object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pmPtr->method));
    }
    return TclOOObjectName(pmPtr->interp, (Object *) object);
}

/*
 * ----------------------------------------------------------------------

    CallContext *contextPtr = (CallContext *)
	    ((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    const char *objectName, *kindName, *methodName =
	    Tcl_GetStringFromObj(mPtr->namePtr, &nameLen);
    Object *declarerPtr;

    if (mPtr->declaringObjectPtr) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (!mPtr->declaringClassPtr) {
	    Tcl_Panic("method not declared in class or object");
	}
	declarerPtr = mPtr->declaringClassPtr->thisPtr;
	kindName = "class";
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),

    CallContext *contextPtr = (CallContext *)
	    ((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    Tcl_Size objectNameLen;

    if (mPtr->declaringObjectPtr) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (!mPtr->declaringClassPtr) {
	    Tcl_Panic("method not declared in class or object");
	}
	declarerPtr = mPtr->declaringClassPtr->thisPtr;
	kindName = "class";
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),

    CallContext *contextPtr = (CallContext *)
	    ((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    Tcl_Size objectNameLen;

    if (mPtr->declaringObjectPtr) {
	declarerPtr = mPtr->declaringObjectPtr;
	kindName = "object";
    } else {
	if (!mPtr->declaringClassPtr) {
	    Tcl_Panic("method not declared in class or object");
	}
	declarerPtr = mPtr->declaringClassPtr->thisPtr;
	kindName = "class";
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),

    for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
	    localPtr=localPtr->nextPtr) {
	if (TclIsVarArgument(localPtr)) {
	    Tcl_Obj *argObj;

	    TclNewObj(argObj);
	    Tcl_ListObjAppendElement(NULL, argObj,
		    Tcl_NewStringObj(localPtr->name, TCL_AUTO_LENGTH));
	    if (localPtr->defValuePtr) {
		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
	    }
	    Tcl_ListObjAppendElement(NULL, argsObj, argObj);
	}
    }

    /*

    ForwardMethod *fmPtr;

    if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (char *)NULL);
	return NULL;
    }

    fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_IncrRefCount(prefixObj);

    ForwardMethod *fmPtr;

    if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
	return NULL;
    }
    if (prefixLen < 1) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"method forward prefix must be non-empty", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", (char *)NULL);
	return NULL;
    }

    fmPtr = (ForwardMethod *) Tcl_Alloc(sizeof(ForwardMethod));
    fmPtr->prefixObj = prefixObj;
    Tcl_IncrRefCount(prefixObj);

    Tcl_Method method,
    const Tcl_MethodType *typePtr,
    void **clientDataPtr)
{
    Method *mPtr = (Method *) method;

    if (mPtr->typePtr == typePtr) {
	if (clientDataPtr) {
	    *clientDataPtr = mPtr->clientData;
	}
	return 1;
    }
    return 0;
}

int
Tcl_MethodIsType(
    Tcl_Method method,
    const Tcl_MethodType *typePtr,
    void **clientDataPtr)
{
    Method *mPtr = (Method *) method;

    if (typePtr->version > TCL_OO_METHOD_VERSION_1) {
	Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
		"Tcl_MethodIsType", "TCL_OO_METHOD_VERSION_1");
    }
    if (mPtr->typePtr == typePtr) {
	if (clientDataPtr) {
	    *clientDataPtr = mPtr->clientData;
	}
	return 1;
    }
    return 0;
}

int
Tcl_MethodIsType2(
    Tcl_Method method,
    const Tcl_MethodType2 *typePtr,
    void **clientDataPtr)
{
    Method *mPtr = (Method *) method;

    if (typePtr->version < TCL_OO_METHOD_VERSION_2) {
	Tcl_Panic("%s: Wrong version in typePtr->version, should be %s",
		"Tcl_MethodIsType2", "TCL_OO_METHOD_VERSION_2");
    }
    if (mPtr->typePtr == (const Tcl_MethodType *) typePtr) {
	if (clientDataPtr) {
	    *clientDataPtr = mPtr->clientData;
	}
	return 1;
    }
    return 0;
}

				 * the reference to the ProcedureMethod
				 * structure. */
{
    ProcedureMethod *pmPtr;
    Tcl_Method method = (Tcl_Method) TclOONewProcInstanceMethod(interp,
	    (Object *) oPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);

    if (!method) {
	return NULL;
    }
    pmPtr->flags = flags & USE_DECLARER_NS;
    pmPtr->preCallProc = preCallPtr;
    pmPtr->postCallProc = postCallPtr;
    pmPtr->errProc = errProc;
    pmPtr->clientData = clientData;
    if (internalTokenPtr) {
	*internalTokenPtr = pmPtr;
    }
    return method;
}

Tcl_Method
TclOONewProcMethodEx(

				 * the reference to the ProcedureMethod
				 * structure. */
{
    ProcedureMethod *pmPtr;
    Tcl_Method method = (Tcl_Method) TclOONewProcMethod(interp,
	    (Class *) clsPtr, flags, nameObj, argsObj, bodyObj, &pmPtr);

    if (!method) {
	return NULL;
    }
    pmPtr->flags = flags & USE_DECLARER_NS;
    pmPtr->preCallProc = preCallPtr;
    pmPtr->postCallProc = postCallPtr;
    pmPtr->errProc = errProc;
    pmPtr->clientData = clientData;
    if (internalTokenPtr) {
	*internalTokenPtr = pmPtr;
    }
    return method;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

 * the right way. Note that we MUST be correct in holding references to Tcl_Obj
 * values, as this is potentially a call into user code.
 */
static inline int
ReadProperty(
    Tcl_Interp *interp,
    Object *oPtr,
    Tcl_Obj *propNameObj)
{
    const char *propName = TclGetString(propNameObj);
    Foundation *fPtr = GetFoundation(interp);
    Tcl_Obj *args[] = {
	fPtr->myName,
	Tcl_ObjPrintf("<ReadProp%s>", propName)
    };
    int code;

    Tcl_IncrRefCount(args[0]);
    Tcl_IncrRefCount(args[1]);
    code = TclOOPrivateObjectCmd(oPtr, interp, 2, args);

    }
}

static inline int
WriteProperty(
    Tcl_Interp *interp,
    Object *oPtr,
    Tcl_Obj *propNameObj,
    Tcl_Obj *valueObj)
{
    const char *propName = TclGetString(propNameObj);
    Foundation *fPtr = GetFoundation(interp);
    Tcl_Obj *args[] = {
	fPtr->myName,
	Tcl_ObjPrintf("<WriteProp%s>", propName),
	valueObj
    };
    int code;

    Tcl_IncrRefCount(args[0]);
    Tcl_IncrRefCount(args[1]);

				 * See GPNFlags for possible values */
    Tcl_Obj *namePtr,		/* The name supplied by the user. */
    GPNCache **cachePtr)	/* Where to cache the table, if the caller
				 * wants that. The contents are to be freed
				 * with Tcl_Free if the cache is used. */
{
    Tcl_Size objc, index, i;
    Tcl_Obj *listPtr = TclOOGetAllObjectProperties(oPtr, flags & GPN_WRITABLE);

    Tcl_Obj **objv;
    GPNCache *tablePtr;

    (void) Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv);
    if (cachePtr && *cachePtr) {
	tablePtr = *cachePtr;
    } else {

	 * We use a recursive call to look this up.
	 */

	Tcl_InterpState foo = Tcl_SaveInterpState(interp, result);
	Tcl_Obj *otherName = GetPropertyName(interp, oPtr,
		flags ^ (GPN_WRITABLE | GPN_FALLING_BACK), namePtr, NULL);
	result = Tcl_RestoreInterpState(interp, foo);
	if (otherName) {
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "property \"%s\" is %s only",
		    TclGetString(otherName),
		    (flags & GPN_WRITABLE) ? "read" : "write"));
	}
    }
    if (!cachePtr) {

	Tcl_Obj *listPtr = TclOOGetAllObjectProperties(oPtr, 0);
	Tcl_Obj *resultPtr = Tcl_NewObj(), **namev;

	Tcl_IncrRefCount(listPtr);
	ListObjGetElements(listPtr, namec, namev);

	for (i = 0; i < namec; ) {
	    code = ReadProperty(interp, oPtr, namev[i]);
	    if (code != TCL_OK) {
		Tcl_DecrRefCount(resultPtr);
		break;
	    }
	    Tcl_DictObjPut(NULL, resultPtr, namev[i],
		    Tcl_GetObjResult(interp));
	    if (++i >= namec) {
		Tcl_SetObjResult(interp, resultPtr);
		break;
	    }
	    Tcl_SetObjResult(interp, Tcl_NewObj());
	}
	Tcl_DecrRefCount(listPtr);
	return code;
    } else if (objc == 1) {
	/*
	 * Read a single named property.
	 */

	namePtr = GetPropertyName(interp, oPtr, 0, objv[0], NULL);
	if (!namePtr) {
	    return TCL_ERROR;
	}
	return ReadProperty(interp, oPtr, namePtr);
    } else if (objc == 2) {
	/*
	 * Special case for writing to one property. Saves fiddling with the
	 * cache in this common case.
	 */

	namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[0], NULL);
	if (!namePtr) {
	    return TCL_ERROR;
	}
	code = WriteProperty(interp, oPtr, namePtr, objv[1]);
	if (code == TCL_OK) {
	    Tcl_SetObjResult(interp, ((Interp *) interp)->emptyObjPtr);
	}
	return code;
    } else {
	/*
	 * Write properties. Slightly tricky because we want to cache the
	 * table of property names.
	 */
	GPNCache *cache = NULL;

	code = TCL_OK;
	for (i = 0; i < objc; i += 2) {
	    namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[i],
		    &cache);
	    if (!namePtr) {
		code = TCL_ERROR;
		break;
	    }
	    code = WriteProperty(interp, oPtr, namePtr, objv[i + 1]);

	    if (code != TCL_OK) {
		break;
	    }
	}
	if (code == TCL_OK) {
	    Tcl_SetObjResult(interp, ((Interp *) interp)->emptyObjPtr);
	}
	ReleasePropertyNameCache(interp, &cache);
	return code;
    }
}

/*

	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
		objv, NULL);
	return TCL_ERROR;
    }

    varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
	    propNamePtr, &aryVar);
    if (!varPtr) {
	return TCL_ERROR;
    }

    valuePtr = TclPtrGetVar(interp, varPtr, aryVar, propNamePtr, NULL,
	    TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG);
    if (!valuePtr) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, valuePtr);
    return TCL_OK;
}

static int

	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
		objv, "value");
	return TCL_ERROR;
    }

    varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
	    propNamePtr, &aryVar);
    if (!varPtr) {
	return TCL_ERROR;
    }

    if (!TclPtrSetVar(interp, varPtr, aryVar, propNamePtr, NULL,
	    objv[objc - 1], TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)) {
	return TCL_ERROR;
    }
    return TCL_OK;
}

// Simple support functions
static void

    int writable,		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
    int *allocated)		/* Address of variable to set to true if a
				 * Tcl_Obj was allocated and may be safely
				 * modified by the caller. */
{
    Tcl_HashTable hashTable;	/* Set of property names built by calling
				 * FindClassProps(). Strictly, the keys are
				 * the set and the values are ignored. */
    Foundation *fPtr = clsPtr->thisPtr->fPtr;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (clsPtr->properties.epoch == fPtr->epoch) {
	if (writable) {
	    if (clsPtr->properties.allWritableCache) {
		*allocated = 0;
		return clsPtr->properties.allWritableCache;
	    }
	} else {
	    if (clsPtr->properties.allReadableCache) {

    }
    Tcl_DeleteHashTable(&hashTable);

    /*
     * Cache the information. Also purges the cache.
     */

    if (clsPtr->properties.epoch != fPtr->epoch) {
	if (clsPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
	    clsPtr->properties.allWritableCache = NULL;
	}
	if (clsPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
	    clsPtr->properties.allReadableCache = NULL;
	}
    }
    clsPtr->properties.epoch = fPtr->epoch;
    if (writable) {
	clsPtr->properties.allWritableCache = result;
    } else {
	clsPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;

}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOGetAllObjectProperties --
 *
 *	Get the sorted list of all properties known to a object, including to
 *	its classes. Manages a cache so this operation is usually cheap.
 *
 * ----------------------------------------------------------------------
 */

Tcl_Obj *
TclOOGetAllObjectProperties(
    Object *oPtr,		/* The object to inspect. Must exist. */
    int writable)		/* Whether to get writable properties. If
				 * false, readable properties will be returned
				 * instead. */
{
    Tcl_HashTable hashTable;	/* Set of property names built by calling
				 * FindObjectProps(). Strictly, the keys are
				 * the set and the values are ignored. */
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (oPtr->properties.epoch == fPtr->epoch) {
	if (writable) {
	    if (oPtr->properties.allWritableCache) {
		return oPtr->properties.allWritableCache;
	    }
	} else {
	    if (oPtr->properties.allReadableCache) {
		return oPtr->properties.allReadableCache;

    Tcl_DeleteHashTable(&hashTable);
    SortPropList(result);

    /*
     * Cache the information.
     */

    if (oPtr->properties.epoch != fPtr->epoch) {
	if (oPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allWritableCache);
	    oPtr->properties.allWritableCache = NULL;
	}
	if (oPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allReadableCache);
	    oPtr->properties.allReadableCache = NULL;
	}
    }
    oPtr->properties.epoch = fPtr->epoch;
    if (writable) {
	oPtr->properties.allWritableCache = result;
    } else {
	oPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;

	"readable", "readwrite", "writable", NULL
    };
    enum Kinds {
	KIND_RO, KIND_RW, KIND_WO
    };
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);

    if (!oPtr) {
	return TCL_ERROR;
    }
    if (!useInstance && !oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
	return TCL_ERROR;
    }

    for (i = 1; i < objc; i++) {
	Tcl_Obj *propObj = objv[i], *nextObj, *argObj, *hyphenated;
	Tcl_Obj *getterScript = NULL, *setterScript = NULL;

	/*
	 * Install the property. Note that TclOOInstallStdPropertyImpls
	 * validates the property name as well.
	 */

	if (TclOOInstallStdPropertyImpls(useInstance, interp, propObj,
		kind != KIND_WO && !getterScript,
		kind != KIND_RO && !setterScript) != TCL_OK) {
	    return TCL_ERROR;
	}

	hyphenated = Tcl_ObjPrintf("-%s", TclGetString(propObj));
	if (useInstance) {
	    TclOORegisterInstanceProperty(oPtr, hyphenated,
		    kind != KIND_WO, kind != KIND_RO);
	} else {
	    TclOORegisterProperty(oPtr->classPtr, hyphenated,
		    kind != KIND_WO, kind != KIND_RO);
	}
	Tcl_BounceRefCount(hyphenated);

	/*
	 * Create property implementation methods by using the right
	 * back-end API, but only if the user has given us the bodies of the
	 * methods we'll make.
	 */

	if (getterScript) {
	    Tcl_Obj *getterName = Tcl_ObjPrintf("<ReadProp-%s>",
		    TclGetString(propObj));
	    Tcl_Obj *argsPtr = Tcl_NewObj();
	    Method *mPtr;

	    Tcl_IncrRefCount(getterScript);
	    if (useInstance) {
		mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
			getterName, argsPtr, getterScript, NULL);
	    } else {
		mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
			getterName, argsPtr, getterScript, NULL);
	    }
	    Tcl_BounceRefCount(getterName);
	    Tcl_BounceRefCount(argsPtr);
	    Tcl_DecrRefCount(getterScript);
	    if (!mPtr) {
		return TCL_ERROR;
	    }
	}
	if (setterScript) {
	    Tcl_Obj *setterName = Tcl_ObjPrintf("<WriteProp-%s>",
		    TclGetString(propObj));
	    Tcl_Obj *argsPtr;
	    Method *mPtr;

	    TclNewLiteralStringObj(argsPtr, "value");
	    Tcl_IncrRefCount(setterScript);
	    if (useInstance) {
		mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
			setterName, argsPtr, setterScript, NULL);
	    } else {
		mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
			setterName, argsPtr, setterScript, NULL);
	    }
	    Tcl_BounceRefCount(setterName);
	    Tcl_BounceRefCount(argsPtr);
	    Tcl_DecrRefCount(setterScript);
	    if (!mPtr) {
		return TCL_ERROR;
	    }
	}
    }
    return TCL_OK;
}


    Tcl_Obj *result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
	return TCL_ERROR;
    }
    clsPtr = TclOOGetClassFromObj(interp, objv[1]);
    if (!clsPtr) {
	return TCL_ERROR;
    }
    for (i = 2; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}

    Tcl_Obj *result;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (!oPtr) {
	return TCL_ERROR;
    }
    for (i = 2; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}

    /*
     * Create the data structure to represent the procedure.
     */

    if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2],
	    objv[3], &procPtr) != TCL_OK) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (creating proc \"%s\")",
		simpleName));

	return TCL_ERROR;
    }

    cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
	TclObjInterpProc, NRInterpProc, procPtr, TclProcDeleteProc);

    /*

	    headerObj, compDictObj) == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, objv[3]);
    return TCL_OK;

  genericOptionError:
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (in %s option)", pushOptions[option]));

    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ZlibStreamCmd --

# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcl::oo 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]
    }
    proc leaktest {script {iterations 3}} {
	set end [getbytes]
	for {set i 0} {$i < $iterations} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [getbytes]
	}
	return [expr {$end - $tmp}]
    }
}

test ooProp-1.1 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}

    list [catch {pt configure -gorp blarg} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad property "-gorp": must be -x
    while executing
"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}}

test ooProp-5.1 {properties: basic leak test} -constraints memory -setup {
    oo::class create parent {
	variable x
	constructor {{v 123}} {set x $v}
    }
} -body {
    oo::configurable create cls {
	superclass parent
	property x
    }
    set obj [cls new]
    leaktest {
	$obj configure -x 123
    }
} -cleanup {
    parent destroy
} -result 0
test ooProp-5.2 {properties: basic leak test} -constraints memory -setup {
    oo::class create parent {
	variable x
	constructor {{v 123}} {set x $v}
    }
} -body {
    oo::configurable create cls {
	superclass parent
	property x
    }
    set obj [cls new]
    leaktest {
	$obj configure -x
    }
} -cleanup {
    parent destroy
} -result 0
test ooProp-5.3 {properties: basic leak test} -constraints memory -setup {
    oo::class create parent {
	variable x
	constructor {{v 123}} {set x $v}
    }
} -body {
    oo::configurable create cls {
	superclass parent
	property x
    }
    set obj [cls new]
    leaktest {
	$obj configure -x [expr {[$obj configure -x] + 1}]
    }
} -cleanup {
    parent destroy
} -result 0
test ooProp-5.4 {properties: basic leak test} -constraints memory -setup {
    oo::class create parent {
	variable x
	constructor {{v 123}} {set x $v}
    }
} -body {
    oo::configurable create cls {
	superclass parent
    }
    set obj [cls new]
    oo::objdefine $obj property x
    leaktest {
	$obj configure -x [expr {[$obj configure -x] + 1}]
    }
} -cleanup {
    parent destroy
} -result 0
test ooProp-5.5 {properties: basic leak test} -constraints memory -setup {
    oo::class create parent {
	variable x
	constructor {{v 123}} {set x $v}
    }
} -body {
    oo::configurable create cls {
	superclass parent
    }
    set obj [cls new]
    oo::objdefine $obj property x
    leaktest {
	$obj configure
    }
} -cleanup {
    parent destroy
} -result 0
test ooProp-5.6 {properties: basic leak test} -constraints memory -setup {
    oo::class create parent {
	variable x y
	constructor {{v 123} {w 234}} {set x $v; set y $w}
    }
} -body {
    oo::configurable create cls {
	superclass parent
    }
    set obj [cls new]
    oo::objdefine $obj property x y
    leaktest {
	list [$obj configure -x 1 -y 2] [$obj configure]
    }
} -cleanup {
    parent destroy
} -result 0

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

			&dwWritten, NULL);
		return 2;
	    }
	    return CheckForCompilerFeature(argv[2]);
	case 'l':
	    if (argc < 3) {
		chars = snprintf(msg, sizeof(msg) - 1,
			"usage: %s -l <linker option> ?<mandatory option> ...?\n"
			"Tests for whether link.exe supports an option\n"
			"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
		WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
			&dwWritten, NULL);
		return 2;
	    }
	    return CheckForLinkerFeature(&argv[2], argc-2);

    const char *substring)
{
    return (strstr(string, substring) != NULL);
}

/*
 * GetVersionFromFile --
 *	Looks for a match string in a file and then returns the version
 *	following the match where a version is anything acceptable to
 *	package provide or package ifneeded.
 */

static const char *
GetVersionFromFile(
    const char *filename,
    const char *match,
    int numdots)

 */

typedef struct Conversation {
    struct Conversation *nextPtr;
				/* The next conversation in the list. */
    RegisteredInterp *riPtr;	/* The info we know about the conversation. */
    HCONV hConv;		/* The DDE handle for this conversation. */
    Tcl_Obj *returnTuplePtr;	/* The result package for this conversation. */
} Conversation;

typedef struct {
    Tcl_Interp *interp;
    int result;
    ATOM service;
    ATOM topic;
    HWND hwnd;
} DdeEnumServices;

typedef struct {
    Conversation *currentConversations;
				/* A list of conversations currently being
				 * processed. */
    RegisteredInterp *interpListPtr;
				/* List of all interpreters registered in the
				 * current thread. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

/*
 * The following variables cannot be placed in thread-local storage. The Mutex
 * ddeMutex guards access to the ddeInstance.
 */

static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance;	/* The application instance handle given to us
				 * by DdeInitialize. */
static int ddeIsServer = 0;

#define TCL_DDE_VERSION		"1.4.5"
#define TCL_DDE_PACKAGE_NAME	"dde"
#define TCL_DDE_COMMAND_NAME	"dde"
#define TCL_DDE_HIDDEN_NAME	"dde"
#define TCL_DDE_SERVICE_NAME	L"TclEval"
#define TCL_DDE_EXECUTE_RESULT	L"$TCLEVAL$EXECUTE$RESULT"

enum TclDdeFlags {
    DDE_FLAG_ASYNC = 1,
    DDE_FLAG_BINARY = 2,
    DDE_FLAG_FORCE = 4
};

TCL_DECLARE_MUTEX(ddeMutex)

#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
#   define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c)
#   define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c)

#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int		Dde_Init(Tcl_Interp *interp);
DLLEXPORT int		Dde_SafeInit(Tcl_Interp *interp);
#if TCL_MAJOR_VERSION < 9
/*
 * With those additional entries, "load tcldde14.dll" works without 3rd
 * argument.
 */
DLLEXPORT int		Tcldde_Init(Tcl_Interp *interp);
DLLEXPORT int		Tcldde_SafeInit(Tcl_Interp *interp);
#endif
#ifdef __cplusplus
}
#endif


 *----------------------------------------------------------------------
 */

int
Dde_Init(
    Tcl_Interp *interp)
{
    if (!Tcl_InitStubs(interp, "8.7-", 0)) {
	return TCL_ERROR;
    }

    Tcl_CreateObjCommand2(interp, TCL_DDE_COMMAND_NAME, DdeObjCmd, NULL, NULL);
    Tcl_CreateExitHandler(DdeExitProc, NULL);
    return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL);
}
#if TCL_MAJOR_VERSION < 9
int
Tcldde_Init(
    Tcl_Interp *interp)

int
Dde_SafeInit(
    Tcl_Interp *interp)
{
    int result = Dde_Init(interp);
    if (result == TCL_OK) {
	Tcl_HideCommand(interp, TCL_DDE_COMMAND_NAME, TCL_DDE_HIDDEN_NAME);
    }
    return result;
}
#if TCL_MAJOR_VERSION < 9
int
Tcldde_SafeInit(
    Tcl_Interp *interp)
{
    return Dde_SafeInit(interp);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * DStringToObj --
 *
 *	Knock-off version of Tcl_DStringToObj() that works with versions of
 *	Tcl before 8.7; it might not be quite as efficient, but it has the
 *	same overall interface.
 *
 *----------------------------------------------------------------------
 */
static inline Tcl_Obj *
DStringToObj(
    Tcl_DString *dsPtr)
{
#if TCL_MAJOR_VERSION < 9
    Tcl_Obj *objPtr = Tcl_NewStringObj(
	    Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr));
    Tcl_DStringFree(dsPtr);
    return objPtr;
#else
    return Tcl_DStringToObj(dsPtr);
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * GetConversation --
 *
 *	Look up the conversation structure for a particular DDE conversation.
 *
 *----------------------------------------------------------------------
 */
static inline Conversation *
GetConversation(
    HCONV hConv)		/* DDE conversation handle. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Conversation *convPtr;
    for (convPtr = tsdPtr->currentConversations;
	    convPtr && (convPtr->hConv != hConv);
	    convPtr = convPtr->nextPtr) {
	/*
	 * Empty loop body.
	 */
    }
    return convPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * GetRegisteredInterp --
 *
 *	Look up a registered interpreter handler for a service name.
 *
 *----------------------------------------------------------------------
 */
static inline RegisteredInterp *
GetRegisteredInterp(
    const WCHAR *name)		/* Service name. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    RegisteredInterp *riPtr;
    for (riPtr = tsdPtr->interpListPtr; riPtr; riPtr = riPtr->nextPtr) {
	if (!_wcsicmp(name, riPtr->name)) {
	    break;
	}
    }
    return riPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Initialize --
 *
 *	Initialize the global DDE instance.

    /*
     * See if the application is already registered; if so, remove its current
     * name from the registry. The deletion of the command will take care of
     * disposing of this entry.
     */

    if (tsdPtr->interpListPtr) {
	nameFound = 1;
    }

    /*
     * Make sure that the DDE server is there. This is done only once, add an
     * exit handler to tear it down.
     */

    if (!ddeInstance) {
	Tcl_MutexLock(&ddeMutex);
	if (!ddeInstance) {
	    if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc,
		    CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
		    | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
		ddeInstance = 0;
	    }
	}
	Tcl_MutexUnlock(&ddeMutex);
    }
    if (!ddeServiceGlobal && nameFound) {
	Tcl_MutexLock(&ddeMutex);
	if (!ddeServiceGlobal && nameFound) {
	    ddeIsServer = 1;
	    Tcl_CreateExitHandler(DdeExitProc, NULL);
	    ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance,
		    TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
	    DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
	} else {
	    ddeIsServer = 0;
	}
	Tcl_MutexUnlock(&ddeMutex);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ReadDdeString --
 *	Get a unicode string from a DDE string handle.
 *
 *----------------------------------------------------------------------
 */
static inline WCHAR *
ReadDdeString(
    Tcl_DString *dsBufferPtr,
    HSZ ddeToken)		/* DDE string handle. */
{
    DWORD len = DdeQueryStringW(ddeInstance, ddeToken, NULL, 0, CP_WINUNICODE);
    Tcl_DStringSetLength(dsBufferPtr, (len + 1) * sizeof(WCHAR) - 1);
    WCHAR *utilString = (WCHAR *) Tcl_DStringValue(dsBufferPtr);
    DdeQueryStringW(ddeInstance, ddeToken, utilString, (DWORD) len + 1,
	    CP_WINUNICODE);
    return utilString;
}

/*
 *----------------------------------------------------------------------
 *
 * DdeSetServerName --
 *
 *	This function is called to associate an ASCII name with a Dde server.

 *
 *----------------------------------------------------------------------
 */

static const WCHAR *
DdeSetServerName(
    Tcl_Interp *interp,
    const WCHAR *name,		/* The name that will be used to refer to the
				 * interpreter in later "send" commands. Must
				 * be globally unique. */
    int flags,			/* DDE_FLAG_FORCE or 0 */
    Tcl_Obj *handlerPtr)	/* Name of the optional proc/command to handle
				 * incoming Dde eval's */
{
    int suffix;
    RegisteredInterp *riPtr, *prevPtr;
    Tcl_DString dString;
    const WCHAR *actualName;

     * name from the registry. The deletion of the command will take care of
     * disposing of this entry.
     */

    for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
	    prevPtr = riPtr, riPtr = riPtr->nextPtr) {
	if (riPtr->interp == interp) {
	    if (name) {
		if (!prevPtr) {
		    tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
		} else {
		    prevPtr->nextPtr = riPtr->nextPtr;
		}
		break;
	    } else {
		/*
		 * The name was NULL, so the caller is asking for the name of
		 * the current interp.
		 */

		return riPtr->name;
	    }
	}
    }

    if (!name) {
	/*
	 * The name was NULL, so the caller is asking for the name of the
	 * current interp, but it doesn't have a name.
	 */

	return L"";
    }

	}
	if (r == TCL_OK) {
	    r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
		    &srvPtrPtr);
	}
	if (r != TCL_OK) {
	    Tcl_DStringInit(&dString);
	    OutputDebugStringW(Tcl_UtfToWCharDString(
		    Tcl_GetString(Tcl_GetObjResult(interp)), TCL_AUTO_LENGTH,
		    &dString));
	    Tcl_DStringFree(&dString);
	    return NULL;
	}

	/*
	 * Pick a name to use for the application. Use "name" if it's not
	 * already in use. Otherwise add a suffix such as " #2", trying larger
	 * and larger numbers until we eventually find one that is unique.
	 */

	offset = lastSuffix = 0;
	suffix = 1;

	while (suffix != lastSuffix) {
	    lastSuffix = suffix;
	    if (suffix > 1) {
		if (suffix == 2) {
		    Tcl_DStringAppend(&dString, (char *)name,
			    wcslen(name) * sizeof(WCHAR));
		    Tcl_DStringAppend(&dString, (char *)L" #",
			    2 * sizeof(WCHAR));
		    offset = Tcl_DStringLength(&dString);
		    Tcl_DStringSetLength(&dString,
			    offset + sizeof(WCHAR) * TCL_INTEGER_SPACE);
		    actualName = (WCHAR *) Tcl_DStringValue(&dString);
		}
		_snwprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset),
			TCL_INTEGER_SPACE, L"%d", suffix);
	    }

	    /*
	     * See if the name is already in use, if so increment suffix.
	     */

	    for (n = 0; n < srvCount; ++n) {
		Tcl_Obj* namePtr;
		Tcl_DString ds;

		Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
		Tcl_DStringInit(&ds);
		Tcl_UtfToWCharDString(Tcl_GetString(namePtr), TCL_AUTO_LENGTH,
			&ds);
		if (!wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds))) {
		    suffix++;
		    Tcl_DStringFree(&ds);
		    break;
		}
		Tcl_DStringFree(&ds);
	    }
	}
    }

    /*
     * We have found a unique name. Now add it to the registry.
     */

    riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
    riPtr->interp = interp;
    riPtr->name = (WCHAR *)
	    Tcl_Alloc((wcslen(actualName) + 1) * sizeof(WCHAR));
    riPtr->nextPtr = tsdPtr->interpListPtr;
    riPtr->handlerPtr = handlerPtr;
    if (riPtr->handlerPtr) {
	Tcl_IncrRefCount(riPtr->handlerPtr);
    }
    tsdPtr->interpListPtr = riPtr;
    wcscpy(riPtr->name, actualName);

    if (Tcl_IsSafe(interp)) {
	Tcl_ExposeCommand(interp, TCL_DDE_HIDDEN_NAME, TCL_DDE_COMMAND_NAME);
    }

    Tcl_CreateObjCommand2(interp, TCL_DDE_COMMAND_NAME, DdeObjCmd, riPtr,
	    DeleteProc);
    if (Tcl_IsSafe(interp)) {
	Tcl_HideCommand(interp, TCL_DDE_COMMAND_NAME, TCL_DDE_HIDDEN_NAME);
    }
    Tcl_DStringFree(&dString);

    /*
     * Re-initialize with the new name.
     */

 *
 * Side effects:
 *	None
 *
 *----------------------------------------------------------------------
 */

static inline RegisteredInterp *
DdeGetRegistrationPtr(
    Tcl_Interp *interp)
{
    RegisteredInterp *riPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;

 *	The interpreter given by riPtr is unregistered.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteProc(
    void *clientData)		/* The interp we are deleting. */
{
    RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
    RegisteredInterp *searchPtr, *prevPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
	    searchPtr && (searchPtr != riPtr);
	    prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
	/*
	 * Empty loop body.
	 */
    }

    if (searchPtr) {
	if (!prevPtr) {
	    tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
	} else {
	    prevPtr->nextPtr = searchPtr->nextPtr;
	}
    }
    Tcl_Free((char *) riPtr->name);
    if (riPtr->handlerPtr) {

 */

static Tcl_Obj *
ExecuteRemoteObject(
    RegisteredInterp *riPtr,	    /* Info about this server. */
    Tcl_Obj *ddeObjectPtr)	    /* The object to execute. */
{
    Tcl_Obj *returnTuplePtr;
    int result = TCL_OK;

    if (!riPtr->handlerPtr && Tcl_IsSafe(riPtr->interp)) {
	Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
		"a handler procedure must be defined for use in a safe "
		"interp", TCL_AUTO_LENGTH));
	Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK",
		(char *)NULL);
	result = TCL_ERROR;
    }

    if (riPtr->handlerPtr) {
	/*
	 * Add the dde request data to the handler proc list.
	 */

	Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr);

	result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr,
		ddeObjectPtr);
	if (result == TCL_OK) {
	    ddeObjectPtr = cmdPtr;
	} else {
	    Tcl_DecrRefCount(cmdPtr);
	}
    }

    /*
     * Execute the script.
     */

    Tcl_IncrRefCount(ddeObjectPtr);
    if (result == TCL_OK) {
	result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
    }
    Tcl_DecrRefCount(ddeObjectPtr);

    /*
     * Package the result into a tuple.
     * TODO: Transfer the whole result option dictionary, a protocol change.
     */

    returnTuplePtr = Tcl_NewListObj(0, NULL);

    Tcl_ListObjAppendElement(NULL, returnTuplePtr, Tcl_NewIntObj(result));

    Tcl_ListObjAppendElement(NULL, returnTuplePtr,
	    Tcl_GetObjResult(riPtr->interp));

    if (result == TCL_ERROR) {
	Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
		TCL_GLOBAL_ONLY);
	if (!errorObjPtr) {
	    errorObjPtr = Tcl_NewObj();
	}
	Tcl_ListObjAppendElement(NULL, returnTuplePtr, errorObjPtr);
	errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
		TCL_GLOBAL_ONLY);
	if (!errorObjPtr) {
	    errorObjPtr = Tcl_NewObj();
	}
	Tcl_ListObjAppendElement(NULL, returnTuplePtr, errorObjPtr);
    }

    return returnTuplePtr;
}

/*
 *----------------------------------------------------------------------
 *
 * DdeServerProc --
 *

    DWORD dlen;
    WCHAR *utilString;
    Tcl_Obj *ddeObjectPtr;
    HDDEDATA ddeReturn = NULL;
    RegisteredInterp *riPtr;
    Conversation *convPtr, *prevConvPtr;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    (void) unused1;
    (void) unused2;

    switch(uType) {
    case XTYP_CONNECT:
	/*
	 * Dde is trying to initialize a conversation with us. Check and make
	 * sure we have a valid topic.
	 */


	Tcl_DStringInit(&dString);




	riPtr = GetRegisteredInterp(ReadDdeString(&dString, ddeTopic));



	Tcl_DStringFree(&dString);





	return (riPtr != NULL ? (HDDEDATA) TRUE : (HDDEDATA) FALSE);

    case XTYP_CONNECT_CONFIRM:
	/*
	 * Dde has decided that we can connect, so it gives us a conversation
	 * handle. We need to keep track of it so we know which execution
	 * result to return in an XTYP_REQUEST.
	 */


	Tcl_DStringInit(&dString);
	riPtr = GetRegisteredInterp(ReadDdeString(&dString, ddeTopic));
	Tcl_DStringFree(&dString);



	if (riPtr) {

	    convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
	    convPtr->nextPtr = tsdPtr->currentConversations;
	    convPtr->returnTuplePtr = NULL;
	    convPtr->hConv = hConv;
	    convPtr->riPtr = riPtr;
	    tsdPtr->currentConversations = convPtr;

	}


	return (HDDEDATA) TRUE;

    case XTYP_DISCONNECT:
	/*
	 * The client has disconnected from our server. Forget this
	 * conversation.
	 */

	for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
		convPtr != NULL;
		prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
	    if (hConv == convPtr->hConv) {
		if (!prevConvPtr) {
		    tsdPtr->currentConversations = convPtr->nextPtr;
		} else {
		    prevConvPtr->nextPtr = convPtr->nextPtr;
		}
		if (convPtr->returnTuplePtr) {
		    Tcl_DecrRefCount(convPtr->returnTuplePtr);
		}
		Tcl_Free((char *) convPtr);
		break;
	    }
	}
	return (HDDEDATA) TRUE;

    case XTYP_REQUEST:
	/*
	 * This could be either a request for a value of a Tcl variable, or it
	 * could be the send command requesting the results of the last
	 * execute.
	 */

	if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
	    return (HDDEDATA) FALSE;
	}

	ddeReturn = (HDDEDATA) FALSE;






	convPtr = GetConversation(hConv);
	if (convPtr) {
	    Tcl_DString dsBuf;
	    const char *returnString;


	    Tcl_DStringInit(&dString);
	    Tcl_DStringInit(&dsBuf);

	    utilString = ReadDdeString(&dString, ddeItem);


	    if (!_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT)) {
		if (convPtr->returnTuplePtr) {
		    returnString = Tcl_GetStringFromObj(
			    convPtr->returnTuplePtr, &len);
		} else {
		    /*
		     * No previous call in the conversation; someone's playing
		     * naughty games. Pretend everything's TCL_OK.
		     */
		    returnString = "0 {}";
		    len = 4;
		}
		if (uFmt == CF_UNICODETEXT) {

		    Tcl_UtfToWCharDString(returnString, len, &dsBuf);
		    returnString = Tcl_DStringValue(&dsBuf);
		    len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
		}
		ddeReturn = DdeCreateDataHandle(ddeInstance,
			(BYTE *) returnString, (DWORD) len + 1, 0, ddeItem,
			uFmt, 0);
	    } else if (Tcl_IsSafe(convPtr->riPtr->interp)) {
		/*
		 * Safe interps don't support direct variable reading; all
		 * variables have to be read through the script handler (if
		 * one is defined, which isn't examined here).
		 */
		ddeReturn = NULL;
	    } else {
		Tcl_DString ds;
		Tcl_Obj *valueObjPtr;
		const char *varName;

		Tcl_DStringInit(&ds);
		varName = Tcl_WCharToUtfDString(utilString,
			wcslen(utilString), &ds);
		valueObjPtr = Tcl_GetVar2Ex(convPtr->riPtr->interp, varName,

			NULL, TCL_GLOBAL_ONLY);
		Tcl_DStringFree(&ds);

		if (valueObjPtr) {
		    returnString = Tcl_GetStringFromObj(valueObjPtr, &len);
		    if (uFmt == CF_UNICODETEXT) {

			Tcl_UtfToWCharDString(returnString, len, &dsBuf);
			returnString = Tcl_DStringValue(&dsBuf);
			len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
		    }
		    ddeReturn = DdeCreateDataHandle(ddeInstance,
			    (BYTE *) returnString, (DWORD) len + 1, 0,
			    ddeItem, uFmt, 0);
		} else {
		    ddeReturn = NULL;


		}
	    }
	    Tcl_DStringFree(&dsBuf);
	    Tcl_DStringFree(&dString);
	}
	return ddeReturn;


    case XTYP_POKE:
#if CBF_FAIL_POKES
	return NULL;
#else
	/*
	 * This is a poke for a Tcl variable, only implemented in
	 * debug/UNICODE mode.
	 */
	ddeReturn = DDE_FNOTPROCESSED;

	if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) {
	    return ddeReturn;
	}







	convPtr = GetConversation(hConv);
	if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
	    Tcl_DString varNameDs, valueDs;
	    const char *varName;
	    Tcl_Obj *valueObj;

	    LPBYTE ptr;

	    Tcl_DStringInit(&dString);
	    Tcl_DStringInit(&varNameDs);





	    Tcl_DStringInit(&valueDs);

	    utilString = ReadDdeString(&dString, ddeItem);
	    varName = Tcl_WCharToUtfDString(utilString, wcslen(utilString),
		    &varNameDs);

	    ptr = DdeAccessData(hData, NULL);

	    if (uFmt == CF_UNICODETEXT) {
		utilString = (WCHAR *) ptr;
		Tcl_WCharToUtfDString(utilString, wcslen(utilString),
			&valueDs);
		valueObj = DStringToObj(&valueDs);
	    } else {
		valueObj = Tcl_NewStringObj((char *) ptr, TCL_AUTO_LENGTH);
	    }

	    DdeUnaccessData(hData);

	    Tcl_SetVar2Ex(convPtr->riPtr->interp, varName, NULL, valueObj,
		    TCL_GLOBAL_ONLY);

	    Tcl_DStringFree(&valueDs);
	    Tcl_DStringFree(&varNameDs);
	    Tcl_DStringFree(&dString);
	    ddeReturn = (HDDEDATA) DDE_FACK;
	}
	return ddeReturn;

#endif
    case XTYP_EXECUTE: {
	/*
	 * Execute this script. The results will be saved into a list object
	 * which will be retrieved later. See ExecuteRemoteObject.
	 */

	Tcl_Obj *returnTuplePtr;
	char *string;
	Tcl_DString dsBuf;






	convPtr = GetConversation(hConv);
	if (!convPtr) {
	    return (HDDEDATA) DDE_FNOTPROCESSED;
	}

	/*
	 * Read the string to execute.
	 */

	utilString = (WCHAR *) DdeAccessData(hData, &dlen);
	string = (char *) utilString;
	if (!dlen) {
	    /* Empty binary array. */
	    ddeObjectPtr = Tcl_NewObj();
	} else if ((dlen & 1) || utilString[dlen / sizeof(WCHAR) - 1]) {
	    /* Cannot be Unicode, so assume utf-8 */
	    if (!string[dlen - 1]) {
		dlen--;
	    }
	    ddeObjectPtr = Tcl_NewStringObj(string, dlen);
	} else {
	    /* Unicode */


	    Tcl_DStringInit(&dsBuf);
	    Tcl_WCharToUtfDString(utilString, dlen / sizeof(WCHAR) - 1, &dsBuf);
	    ddeObjectPtr = DStringToObj(&dsBuf);


	}
	Tcl_IncrRefCount(ddeObjectPtr);
	DdeUnaccessData(hData);

	/*
	 * Release previous result tuple, if there is one
	 */

	if (convPtr->returnTuplePtr) {
	    Tcl_DecrRefCount(convPtr->returnTuplePtr);
	}
	convPtr->returnTuplePtr = NULL;

	returnTuplePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);



	/*
	 * Attach the result tuple to the conversation, ready for pickup.
	 * Note that this called user code, so we need to loop up the
	 * conversation again for safety.
	 */

	convPtr = GetConversation(hConv);
	if (convPtr) {
	    Tcl_IncrRefCount(returnTuplePtr);
	    convPtr->returnTuplePtr = returnTuplePtr;
	} else {
	    Tcl_DecrRefCount(returnTuplePtr);
	}
	Tcl_DecrRefCount(ddeObjectPtr);



	return (HDDEDATA) DDE_FACK;

    }

    case XTYP_WILDCONNECT: {
	/*
	 * Dde wants a list of services and topics that we support.
	 */

	HSZPAIR *returnPtr;

	DWORD i, numItems;

	for (numItems = 0, riPtr = tsdPtr->interpListPtr;
		riPtr != NULL && numItems < UINT_MAX;
		numItems++, riPtr = riPtr->nextPtr) {
	    /*
	     * Empty loop body.
	     */
	}
	if ((size_t)numItems >= UINT_MAX / sizeof(HSZPAIR)) {

	    return NULL;
	}

	/*
	 * Allocate a buffer and write the service/topic descriptors into it.
	 */

	ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
		(numItems + 1) * (DWORD) sizeof(HSZPAIR), 0, 0, 0, 0);
	returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, NULL);

	for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
		i++, riPtr = riPtr->nextPtr) {
	    returnPtr[i].hszSvc = DdeCreateStringHandleW(ddeInstance,
		    TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
	    returnPtr[i].hszTopic = DdeCreateStringHandleW(ddeInstance,
		    riPtr->name, CP_WINUNICODE);
	}
	returnPtr[i].hszSvc = NULL;

    Tcl_Interp *interp,		/* Used to report errors. */
    const WCHAR *name,		/* The connection to use. */
    HCONV *ddeConvPtr)
{
    HSZ ddeTopic, ddeService;
    HCONV ddeConv;

    ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME,
	    CP_WINUNICODE);
    ddeTopic = DdeCreateStringHandleW(ddeInstance, name, CP_WINUNICODE);

    ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
    DdeFreeStringHandle(ddeInstance, ddeService);
    DdeFreeStringHandle(ddeInstance, ddeTopic);

    if (ddeConv == (HCONV) NULL) {
	if (interp) {
	    Tcl_DString dString;

	    Tcl_DStringInit(&dString);
	    Tcl_WCharToUtfDString(name, wcslen(name), &dString);
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "no registered server named \"%s\"",
		    Tcl_DStringValue(&dString)));
	    Tcl_DStringFree(&dString);
	    Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (char *)NULL);
	}
	return TCL_ERROR;
    }

    *ddeConvPtr = ddeConv;

    /*
     * Register and create the callback window.
     */

    RegisterClassExW(&wc);
    es->hwnd = CreateWindowExW(0, szDdeClientClassName, szDdeClientWindowName,
	    WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID) es);
    return TCL_OK;
}

static LRESULT CALLBACK
DdeClientWindowProc(
    HWND hwnd,			/* What window is the message for */
    UINT uMsg,			/* The type of message received */
    WPARAM wParam,
    LPARAM lParam)		/* (Potentially) our local handle */
{
    switch (uMsg) {
    case WM_CREATE: {
	LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;

	DdeEnumServices *es = (DdeEnumServices *) lpcs->lpCreateParams;

#ifdef _WIN64
	SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) es);
#else
	SetWindowLongW(hwnd, GWL_USERDATA, (LONG) es);
#endif
	return (LRESULT) 0L;

static LRESULT
DdeServicesOnAck(
    HWND hwnd,
    WPARAM wParam,
    LPARAM lParam)
{
    HWND hwndRemote = (HWND) wParam;
    ATOM service = (ATOM) LOWORD(lParam);
    ATOM topic = (ATOM) HIWORD(lParam);
    DdeEnumServices *es;
    WCHAR sz[255];
    Tcl_DString dString;

#ifdef _WIN64
    es = (DdeEnumServices *) GetWindowLongPtrW(hwnd, GWLP_USERDATA);
#else
    es = (DdeEnumServices *) GetWindowLongW(hwnd, GWL_USERDATA);
#endif

    if (((es->service == (ATOM)0) || (es->service == service))
	    && ((es->topic == (ATOM)0) || (es->topic == topic))) {
	Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
	Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);

	GlobalGetAtomNameW(service, sz, 255);
	Tcl_DStringInit(&dString);
	Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
	Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(
		Tcl_DStringValue(&dString), TCL_AUTO_LENGTH));
	Tcl_DStringFree(&dString);
	GlobalGetAtomNameW(topic, sz, 255);

	Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
	Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(
		Tcl_DStringValue(&dString), TCL_AUTO_LENGTH));
	Tcl_DStringFree(&dString);

	/*
	 * Adding the hwnd as a third list element provides a unique
	 * identifier in the case of multiple servers with the name
	 * application and topic names.
	 */
	/*
	 * Needs a TIP though:
	 * Tcl_ListObjAppendElement(NULL, matchPtr,
	 *	Tcl_NewLongObj((long) hwndRemote));
	 */

	if (Tcl_IsShared(resultPtr)) {
	    resultPtr = Tcl_DuplicateObj(resultPtr);
	}
	if (Tcl_ListObjAppendElement(es->interp, resultPtr,
		matchPtr) == TCL_OK) {
	    Tcl_SetObjResult(es->interp, resultPtr);
	}
    }

    /*
     * Tell the server we are no longer interested.
     */

    PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM) hwnd, 0L);
    return 0L;
}

static BOOL CALLBACK
DdeEnumWindowsCallback(
    HWND hwndTarget,
    LPARAM lParam)
{
    DWORD_PTR dwResult = 0;
    DdeEnumServices *es = (DdeEnumServices *) lParam;

    SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM) es->hwnd,
	    MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
	    &dwResult);
    return TRUE;
}

static int
DdeGetServicesList(

 *	The interp's result object is changed.
 *
 *----------------------------------------------------------------------
 */

static void
SetDdeError(
    Tcl_Interp *interp)		/* The interp to put the message in. */
{
    const char *errorMessage, *errorCode;

    switch (DdeGetLastError(ddeInstance)) {
    case DMLERR_DATAACKTIMEOUT:
    case DMLERR_EXECACKTIMEOUT:
    case DMLERR_POKEACKTIMEOUT: