Implementation of TIP #257. Incomplete due to missing Win build support.

1 files changed, 1831 insertions, 0 deletions

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
new file mode 100644
index 0000000..77f9970
--- /dev/null
+++ b/generic/tclOODefineCmds.c
@@ -0,0 +1,1831 @@
+/*
+ * tclOODefineCmds.c --
+ *
+ *	This file contains the implementation of the ::oo::define command,
+ *	part of the object-system core (NB: not Tcl_Obj, but ::oo).
+ *
+ * Copyright (c) 2006-2008 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclOODefineCmds.c,v 1.4 2008/05/31 11:42:18 dkf Exp $
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Forward declarations.
+ */
+
+static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
+static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
+			    Tcl_Namespace *const namespacePtr);
+static inline int	InitDefineContext(Tcl_Interp *interp,
+			    Tcl_Namespace *namespacePtr, Object *oPtr,
+			    int objc, Tcl_Obj *const objv[]);
+static inline void	RecomputeClassCacheFlag(Object *oPtr);
+static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
+			    int useClass, Tcl_Obj *const fromPtr,
+			    Tcl_Obj *const toPtr);
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * BumpGlobalEpoch --
+ *	Utility that ensures that call chains that are invalid will get thrown
+ *	away at an appropriate time. Note that exactly which epoch gets
+ *	advanced will depend on exactly what the class is tangled up in; in
+ *	the worst case, the simplest option is to advance the global epoch,
+ *	causing *everything* to be thrown away on next usage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+BumpGlobalEpoch(
+    Tcl_Interp *interp,
+    Class *classPtr)
+{
+    if (classPtr != NULL
+	    && 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
+	 * epoch if it has any mixins; the relation between a class and its
+	 * representative object is special. But it won't hurt.
+	 */
+
+	if (classPtr->thisPtr->mixins.num > 0) {
+	    classPtr->thisPtr->epoch++;
+	}
+	return;
+    }
+
+    /*
+     * Either there's no class (?!) or we're reconfiguring something that is
+     * in use. Force regeneration of call chains.
+     */
+
+    TclOOGetFoundation(interp)->epoch++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RecomputeClassCacheFlag --
+ *	Determine whether the object is prototypical of its class, and hence
+ *	able to use the class's method chain cache.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+RecomputeClassCacheFlag(
+    Object *oPtr)
+{
+    if ((oPtr->methodsPtr == NULL || oPtr->methodsPtr->numEntries == 0)
+	    && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) {
+	oPtr->flags |= USE_CLASS_CACHE;
+    } else {
+	oPtr->flags &= ~USE_CLASS_CACHE;
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectSetFilters --
+ *	Install a list of filter method names into an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOObjectSetFilters(
+    Object *oPtr,
+    int numFilters,
+    Tcl_Obj *const *filters)
+{
+    int i;
+
+    if (oPtr->filters.num) {
+	Tcl_Obj *filterObj;
+
+	FOREACH(filterObj, oPtr->filters) {
+	    Tcl_DecrRefCount(filterObj);
+	}
+    }
+
+    if (numFilters == 0) {
+	/*
+	 * No list of filters was supplied, so we're deleting filters.
+	 */
+
+	ckfree((char *) oPtr->filters.list);
+	oPtr->filters.list = NULL;
+	oPtr->filters.num = 0;
+	RecomputeClassCacheFlag(oPtr);
+    } else {
+	/*
+	 * We've got a list of filters, so we're creating filters.
+	 */
+
+	Tcl_Obj **filtersList;
+	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */
+
+	if (oPtr->filters.num == 0) {
+	    filtersList = (Tcl_Obj **) ckalloc(size);
+	} else {
+	    filtersList = (Tcl_Obj **)
+		    ckrealloc((char *) oPtr->filters.list, size);
+	}
+	for (i=0 ; i<numFilters ; i++) {
+	    filtersList[i] = filters[i];
+	    Tcl_IncrRefCount(filters[i]);
+	}
+	oPtr->filters.list = filtersList;
+	oPtr->filters.num = numFilters;
+	oPtr->flags &= ~USE_CLASS_CACHE;
+    }
+    oPtr->epoch++;		/* Only this object can be affected. */
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassSetFilters --
+ *	Install a list of filter method names into a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOClassSetFilters(
+    Tcl_Interp *interp,
+    Class *classPtr,
+    int numFilters,
+    Tcl_Obj *const *filters)
+{
+    int i;
+
+    if (classPtr->filters.num) {
+	Tcl_Obj *filterObj;
+
+	FOREACH(filterObj, classPtr->filters) {
+	    Tcl_DecrRefCount(filterObj);
+	}
+    }
+
+    if (numFilters == 0) {
+	/*
+	 * No list of filters was supplied, so we're deleting filters.
+	 */
+
+	ckfree((char *) classPtr->filters.list);
+	classPtr->filters.list = NULL;
+	classPtr->filters.num = 0;
+    } else {
+	/*
+	 * We've got a list of filters, so we're creating filters.
+	 */
+
+	Tcl_Obj **filtersList;
+	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */
+
+	if (classPtr->filters.num == 0) {
+	    filtersList = (Tcl_Obj **) ckalloc(size);
+	} else {
+	    filtersList = (Tcl_Obj **)
+		    ckrealloc((char *) classPtr->filters.list, size);
+	}
+	for (i=0 ; i<numFilters ; i++) {
+	    filtersList[i] = filters[i];
+	    Tcl_IncrRefCount(filters[i]);
+	}
+	classPtr->filters.list = filtersList;
+	classPtr->filters.num = numFilters;
+    }
+
+    /*
+     * There may be many objects affected, so bump the global epoch.
+     */
+
+    BumpGlobalEpoch(interp, classPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectSetMixins --
+ *	Install a list of mixin classes into an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOObjectSetMixins(
+    Object *oPtr,
+    int numMixins,
+    Class *const *mixins)
+{
+    Class *mixinPtr;
+    int i;
+
+    if (numMixins == 0) {
+	if (oPtr->mixins.num != 0) {
+	    FOREACH(mixinPtr, oPtr->mixins) {
+		TclOORemoveFromInstances(oPtr, mixinPtr);
+	    }
+	    ckfree((char *) oPtr->mixins.list);
+	    oPtr->mixins.num = 0;
+	}
+	RecomputeClassCacheFlag(oPtr);
+    } else {
+	if (oPtr->mixins.num != 0) {
+	    FOREACH(mixinPtr, oPtr->mixins) {
+		if (mixinPtr != oPtr->selfCls) {
+		    TclOORemoveFromInstances(oPtr, mixinPtr);
+		}
+	    }
+	    oPtr->mixins.list = (Class **)
+		    ckrealloc((char *) oPtr->mixins.list,
+		    sizeof(Class *) * numMixins);
+	} else {
+	    oPtr->mixins.list = (Class **)
+		    ckalloc(sizeof(Class *) * numMixins);
+	    oPtr->flags &= ~USE_CLASS_CACHE;
+	}
+	oPtr->mixins.num = numMixins;
+	memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
+	FOREACH(mixinPtr, oPtr->mixins) {
+	    if (mixinPtr != oPtr->selfCls) {
+		TclOOAddToInstances(oPtr, mixinPtr);
+	    }
+	}
+    }
+    oPtr->epoch++;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassSetMixins --
+ *	Install a list of mixin classes into a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOClassSetMixins(
+    Tcl_Interp *interp,
+    Class *classPtr,
+    int numMixins,
+    Class *const *mixins)
+{
+    Class *mixinPtr;
+    int i;
+
+    if (numMixins == 0) {
+	if (classPtr->mixins.num != 0) {
+	    FOREACH(mixinPtr, classPtr->mixins) {
+		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+	    }
+	    ckfree((char *) classPtr->mixins.list);
+	    classPtr->mixins.num = 0;
+	}
+    } else {
+	if (classPtr->mixins.num != 0) {
+	    FOREACH(mixinPtr, classPtr->mixins) {
+		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+	    }
+	    classPtr->mixins.list = (Class **)
+		    ckrealloc((char *) classPtr->mixins.list,
+		    sizeof(Class *) * numMixins);
+	} else {
+	    classPtr->mixins.list = (Class **)
+		    ckalloc(sizeof(Class *) * numMixins);
+	}
+	classPtr->mixins.num = numMixins;
+	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
+	FOREACH(mixinPtr, classPtr->mixins) {
+	    TclOOAddToMixinSubs(classPtr, mixinPtr);
+	}
+    }
+    BumpGlobalEpoch(interp, classPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RenameDeleteMethod --
+ *	Core of the code to rename and delete methods.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+RenameDeleteMethod(
+    Tcl_Interp *interp,
+    Object *oPtr,
+    int useClass,
+    Tcl_Obj *const fromPtr,
+    Tcl_Obj *const toPtr)
+{
+    Tcl_HashEntry *hPtr, *newHPtr = NULL;
+    Method *mPtr;
+    int isNew;
+
+    if (!useClass) {
+	if (!oPtr->methodsPtr) {
+	noSuchMethod:
+	    Tcl_AppendResult(interp, "method ", TclGetString(fromPtr),
+		    " does not exist", NULL);
+	    return TCL_ERROR;
+	}
+	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr);
+	if (hPtr == NULL) {
+	    goto noSuchMethod;
+	}
+	if (toPtr) {
+	    newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr,
+		    &isNew);
+	    if (hPtr == newHPtr) {
+	    renameToSelf:
+		Tcl_AppendResult(interp, "cannot rename method to itself",
+			NULL);
+		return TCL_ERROR;
+	    } else if (!isNew) {
+	    renameToExisting:
+		Tcl_AppendResult(interp, "method called ",
+			TclGetString(toPtr), " already exists", NULL);
+		return TCL_ERROR;
+	    }
+	}
+    } else {
+	hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
+		(char *) fromPtr);
+	if (hPtr == NULL) {
+	    goto noSuchMethod;
+	}
+	if (toPtr) {
+	    newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods,
+		    (char *) toPtr, &isNew);
+	    if (hPtr == newHPtr) {
+		goto renameToSelf;
+	    } else if (!isNew) {
+		goto renameToExisting;
+	    }
+	}
+    }
+
+    /*
+     * Complete the splicing by changing the method's name.
+     */
+
+    mPtr = Tcl_GetHashValue(hPtr);
+    if (toPtr) {
+	Tcl_IncrRefCount(toPtr);
+	Tcl_DecrRefCount(mPtr->namePtr);
+	mPtr->namePtr = toPtr;
+	Tcl_SetHashValue(newHPtr, mPtr);
+    } else {
+	if (!useClass) {
+	    RecomputeClassCacheFlag(oPtr);
+	}
+	TclOODelMethodRef(mPtr);
+    }
+    Tcl_DeleteHashEntry(hPtr);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOUnknownDefinition --
+ *	Handles what happens when an unknown command is encountered during the
+ *	processing of a definition script. Works by finding a command in the
+ *	operating definition namespace that the requested command is a unique
+ *	prefix of.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOUnknownDefinition(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+    Tcl_HashSearch search;
+    Tcl_HashEntry *hPtr;
+    int soughtLen;
+    const char *soughtStr, *matchedStr = NULL;
+
+    if (objc < 2) {
+	Tcl_AppendResult(interp, "bad call of unknown handler", NULL);
+	return TCL_ERROR;
+    }
+    if (TclOOGetDefineCmdContext(interp) == NULL) {
+	return TCL_ERROR;
+    }
+
+    soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen);
+    if (soughtLen == 0) {
+	goto noMatch;
+    }
+    hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+    while (hPtr != NULL) {
+	const char *nameStr = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
+
+	if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
+	    if (matchedStr != NULL) {
+		goto noMatch;
+	    }
+	    matchedStr = nameStr;
+	}
+	hPtr = Tcl_NextHashEntry(&search);
+    }
+
+    if (matchedStr != NULL) {
+	/*
+	 * Got one match, and only one match!
+	 */
+
+	Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
+	int result;
+
+	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
+	Tcl_IncrRefCount(newObjv[0]);
+	if (objc > 2) {
+	    memcpy(newObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc-2));
+	}
+	result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
+	Tcl_DecrRefCount(newObjv[0]);
+	TclStackFree(interp, newObjv);
+	return result;
+    }
+
+  noMatch:
+    Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL);
+    return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * FindCommand --
+ *	Specialized version of Tcl_FindCommand that handles command prefixes
+ *	and disallows namespace magic.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Command
+FindCommand(
+    Tcl_Interp *interp,
+    Tcl_Obj *stringObj,
+    Tcl_Namespace *const namespacePtr)
+{
+    int length;
+    const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length);
+    register Namespace *const nsPtr = (Namespace *) namespacePtr;
+    FOREACH_HASH_DECLS;
+    Tcl_Command cmd, cmd2;
+
+    /*
+     * If someone is playing games, we stop playing right now.
+     */
+
+    if (string[0] == '\0' || strstr(string, "::") != NULL) {
+	return NULL;
+    }
+
+    /*
+     * Do the exact lookup first.
+     */
+
+    cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY);
+    if (cmd != NULL) {
+	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) == 0) {
+	    if (cmd != NULL) {
+		return NULL;
+	    }
+	    cmd = cmd2;
+	}
+    }
+
+    /*
+     * Either we found one thing or we found nothing. Either way, return it.
+     */
+
+    return cmd;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitDefineContext --
+ *	Does the magic incantations necessary to push the special stack frame
+ *	used when processing object definitions. It is up to the caller to
+ *	dispose of the frame (with TclPopStackFrame) when finished.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+InitDefineContext(
+    Tcl_Interp *interp,
+    Tcl_Namespace *namespacePtr,
+    Object *oPtr,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    CallFrame *framePtr, **framePtrPtr = &framePtr;
+    int result;
+
+    /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
+
+    result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
+	    namespacePtr, FRAME_IS_OO_DEFINE);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+    framePtr->clientData = oPtr;
+    framePtr->objc = objc;
+    framePtr->objv = objv;	/* Reference counts do not need to be
+				 * incremented here. */
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetDefineCmdContext --
+ *	Extracts the magic token from the current stack frame, or returns NULL
+ *	(and leaves an error message) otherwise.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+TclOOGetDefineCmdContext(
+    Tcl_Interp *interp)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    if ((iPtr->framePtr == NULL)
+	    || (iPtr->framePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
+	Tcl_AppendResult(interp, "this command may only be called from within"
+		" the context of an ::oo::define or ::oo::objdefine command",
+		NULL);
+	return NULL;
+    }
+    return (Tcl_Object) iPtr->framePtr->clientData;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineObjCmd --
+ *	Implementation of the "oo::define" command. Works by effectively doing
+ *	the same as 'namespace eval', but with extra magic applied so that the
+ *	object to be modified is known to the commands in the target
+ *	namespace. Also does ensemble-like tricks with dispatch so that error
+ *	messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Foundation *fPtr = TclOOGetFoundation(interp);
+    int result;
+    Object *oPtr;
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, TclGetString(objv[1]),
+		" does not refer to a class", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make the oo::define namespace the current namespace and evaluate the
+     * command(s).
+     */
+
+    if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){
+	return TCL_ERROR;
+    }
+
+    AddRef(oPtr);
+    if (objc == 3) {
+	result = TclEvalObjEx(interp, objv[2], 0,
+		((Interp *)interp)->cmdFramePtr, 2);
+
+	if (result == TCL_ERROR) {
+	    int length;
+	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+	    int limit = 60;
+	    int overflow = (length > limit);
+
+	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		    "\n    (in definition script for object \"%.*s%s\" line %d)",
+		    (overflow ? limit : length), objName,
+		    (overflow ? "..." : ""), interp->errorLine));
+	}
+    } else {
+	Tcl_Obj *objPtr, *obj2Ptr, **objs;
+	Interp *iPtr = (Interp *) interp;
+	Tcl_Command cmd;
+	int dummy;
+
+	/*
+	 * More than one argument: fire them through the ensemble processing
+	 * engine so that everything appears to be good and proper in error
+	 * messages. Note that we cannot just concatenate and send through
+	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+	 * cannot go through Tcl_EvalObjv without the extra work to pre-find
+	 * the command, as that finds command names in the wrong namespace at
+	 * the moment. Ugly!
+	 */
+
+	if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+	    iPtr->ensembleRewrite.sourceObjs = objv;
+	    iPtr->ensembleRewrite.numRemovedObjs = 3;
+	    iPtr->ensembleRewrite.numInsertedObjs = 1;
+	} else {
+	    int ni = iPtr->ensembleRewrite.numInsertedObjs;
+	    if (ni < 3) {
+		iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+	    } else {
+		iPtr->ensembleRewrite.numInsertedObjs -= 2;
+	    }
+	}
+
+	/*
+	 * Build the list of arguments using a Tcl_Obj as a workspace. See
+	 * comments above for why these contortions are necessary.
+	 */
+
+	objPtr = Tcl_NewObj();
+	obj2Ptr = Tcl_NewObj();
+	cmd = FindCommand(interp, objv[2], fPtr->defineNs);
+	if (cmd == NULL) {
+	    /* punt this case! */
+	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+	} else {
+	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+	}
+	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+	result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+	Tcl_DecrRefCount(objPtr);
+    }
+    DelRef(oPtr);
+
+    /*
+     * Restore the previous "current" namespace.
+     */
+
+    TclPopStackFrame(interp);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjDefObjCmd --
+ *	Implementation of the "oo::objdefine" command. Works by effectively
+ *	doing the same as 'namespace eval', but with extra magic applied so
+ *	that the object to be modified is known to the commands in the target
+ *	namespace. Also does ensemble-like tricks with dispatch so that error
+ *	messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOObjDefObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Foundation *fPtr = TclOOGetFoundation(interp);
+    int result;
+    Object *oPtr;
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make the oo::objdefine namespace the current namespace and evaluate the
+     * command(s).
+     */
+
+    if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+	return TCL_ERROR;
+    }
+
+    AddRef(oPtr);
+    if (objc == 3) {
+	result = TclEvalObjEx(interp, objv[2], 0,
+		((Interp *)interp)->cmdFramePtr, 2);
+
+	if (result == TCL_ERROR) {
+	    int length;
+	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
+	    int limit = 60;
+	    int overflow = (length > limit);
+
+	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		    "\n    (in definition script for object \"%.*s%s\" line %d)",
+		    (overflow ? limit : length), objName,
+		    (overflow ? "..." : ""), interp->errorLine));
+	}
+    } else {
+	Tcl_Obj *objPtr, *obj2Ptr, **objs;
+	Interp *iPtr = (Interp *) interp;
+	Tcl_Command cmd;
+	int dummy;
+
+	/*
+	 * More than one argument: fire them through the ensemble processing
+	 * engine so that everything appears to be good and proper in error
+	 * messages. Note that we cannot just concatenate and send through
+	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+	 * cannot go through Tcl_EvalObjv without the extra work to pre-find
+	 * the command, as that finds command names in the wrong namespace at
+	 * the moment. Ugly!
+	 */
+
+	if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+	    iPtr->ensembleRewrite.sourceObjs = objv;
+	    iPtr->ensembleRewrite.numRemovedObjs = 3;
+	    iPtr->ensembleRewrite.numInsertedObjs = 1;
+	} else {
+	    int ni = iPtr->ensembleRewrite.numInsertedObjs;
+	    if (ni < 3) {
+		iPtr->ensembleRewrite.numRemovedObjs += 3 - ni;
+	    } else {
+		iPtr->ensembleRewrite.numInsertedObjs -= 2;
+	    }
+	}
+
+	/*
+	 * Build the list of arguments using a Tcl_Obj as a workspace. See
+	 * comments above for why these contortions are necessary.
+	 */
+
+	objPtr = Tcl_NewObj();
+	obj2Ptr = Tcl_NewObj();
+	cmd = FindCommand(interp, objv[2], fPtr->objdefNs);
+	if (cmd == NULL) {
+	    /* punt this case! */
+	    Tcl_AppendObjToObj(obj2Ptr, objv[2]);
+	} else {
+	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+	}
+	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
+	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+	result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE);
+	Tcl_DecrRefCount(objPtr);
+    }
+    DelRef(oPtr);
+
+    /*
+     * Restore the previous "current" namespace.
+     */
+
+    TclPopStackFrame(interp);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSelfObjCmd --
+ *	Implementation of the "self" subcommand of the "oo::define" command.
+ *	Works by effectively doing the same as 'namespace eval', but with
+ *	extra magic applied so that the object to be modified is known to the
+ *	commands in the target namespace. Also does ensemble-like tricks with
+ *	dispatch so that error messages are clearer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSelfObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Foundation *fPtr = TclOOGetFoundation(interp);
+    int result;
+    Object *oPtr;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Make the oo::objdefine namespace the current namespace and evaluate the
+     * command(s).
+     */
+
+    if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
+	return TCL_ERROR;
+    }
+
+    AddRef(oPtr);
+    if (objc == 2) {
+	result = TclEvalObjEx(interp, objv[1], 0,
+		((Interp *)interp)->cmdFramePtr, 2);
+
+	if (result == TCL_ERROR) {
+	    int length;
+	    const char *objName = Tcl_GetStringFromObj(
+		    TclOOObjectName(interp, oPtr), &length);
+	    int limit = 60;
+	    int overflow = (length > limit);
+
+	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		    "\n    (in definition script for object \"%.*s%s\" line %d)",
+		    (overflow ? limit : length), objName,
+		    (overflow ? "..." : ""), interp->errorLine));
+	}
+    } else {
+	Tcl_Obj *objPtr, *obj2Ptr, **objs;
+	Interp *iPtr = (Interp *) interp;
+	Tcl_Command cmd;
+	int dummy;
+
+	/*
+	 * More than one argument: fire them through the ensemble processing
+	 * engine so that everything appears to be good and proper in error
+	 * messages. Note that we cannot just concatenate and send through
+	 * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we
+	 * cannot go through Tcl_EvalObjv without the extra work to pre-find
+	 * the command, as that finds command names in the wrong namespace at
+	 * the moment. Ugly!
+	 */
+
+	if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+	    iPtr->ensembleRewrite.sourceObjs = objv;
+	    iPtr->ensembleRewrite.numRemovedObjs = 2;
+	    iPtr->ensembleRewrite.numInsertedObjs = 1;
+	} else {
+	    int ni = iPtr->ensembleRewrite.numInsertedObjs;
+	    if (ni < 2) {
+		iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
+	    } else {
+		iPtr->ensembleRewrite.numInsertedObjs -= 1;
+	    }
+	}
+
+	/*
+	 * Build the list of arguments using a Tcl_Obj as a workspace. See
+	 * comments above for why these contortions are necessary.
+	 */
+
+	objPtr = Tcl_NewObj();
+	obj2Ptr = Tcl_NewObj();
+	cmd = FindCommand(interp, objv[1], fPtr->objdefNs);
+	if (cmd == NULL) {
+	    /* punt this case! */
+	    Tcl_AppendObjToObj(obj2Ptr, objv[1]);
+	} else {
+	    Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
+	}
+	Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+	Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2);
+	Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
+
+	result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE);
+	Tcl_DecrRefCount(objPtr);
+    }
+    DelRef(oPtr);
+
+    /*
+     * Restore the previous "current" namespace.
+     */
+
+    TclPopStackFrame(interp);
+    return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineClassObjCmd --
+ *	Implementation of the "class" subcommand of the "oo::objdefine"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineClassObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr, *o2Ptr;
+    Foundation *fPtr = TclOOGetFoundation(interp);
+
+    /*
+     * Parse the context to get the object to operate on.
+     */
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr == fPtr->objectCls->thisPtr) {
+	Tcl_AppendResult(interp,
+		"may not modify the class of the root object", NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == fPtr->classCls->thisPtr) {
+	Tcl_AppendResult(interp,
+		"may not modify the class of the class of classes", 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;
+    }
+    o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (o2Ptr == NULL) {
+	return TCL_ERROR;
+    }
+    if (o2Ptr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "the class of an object must be a class",
+		NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Apply semantic checks. In particular, classes and non-classes are not
+     * interchangable (too complicated to do the conversion!) so we must
+     * produce an error if any attempt is made to swap from one to the other.
+     */
+
+    if ((oPtr->classPtr == NULL) == TclOOIsReachable(fPtr->classCls,
+	    o2Ptr->classPtr)) {
+	Tcl_AppendResult(interp, "may not change a ",
+		(oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
+		(oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Set the object's class.
+     */
+
+    if (oPtr->selfCls != o2Ptr->classPtr) {
+	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+	oPtr->selfCls = o2Ptr->classPtr;
+	TclOOAddToInstances(oPtr, oPtr->selfCls);
+	if (oPtr->classPtr != NULL) {
+	    BumpGlobalEpoch(interp, oPtr->classPtr);
+	} else {
+	    oPtr->epoch++;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineConstructorObjCmd --
+ *	Implementation of the "constructor" subcommand of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineConstructorObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr;
+    Class *clsPtr;
+    Tcl_Method method;
+    int bodyLength;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Extract and validate the context, which is the class that we wish to
+     * modify.
+     */
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    Tcl_GetStringFromObj(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 == NULL) {
+	    return TCL_ERROR;
+	}
+    } else {
+	/*
+	 * Delete the constructor method record and set the field in the
+	 * class record to NULL.
+	 */
+
+	method = NULL;
+    }
+
+    /*
+     * Place the method structure in the class record. Note that we might not
+     * immediately delete the constructor as this might be being done during
+     * execution of the constructor itself.
+     */
+
+    Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineDeleteMethodObjCmd --
+ *	Implementation of the "deletemethod" subcommand of the "oo::define"
+ *	and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDeleteMethodObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceDeleteMethod = (clientData != NULL);
+    Object *oPtr;
+    int i;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (!isInstanceDeleteMethod && !oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	return TCL_ERROR;
+    }
+
+    for (i=1 ; i<objc ; i++) {
+	/*
+	 * Delete the method structure from the appropriate hash table.
+	 */
+
+	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
+		objv[i], NULL) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+    }
+
+    if (isInstanceDeleteMethod) {
+	oPtr->epoch++;
+    } else {
+	BumpGlobalEpoch(interp, oPtr->classPtr);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineDestructorObjCmd --
+ *	Implementation of the "destructor" subcommand of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineDestructorObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr;
+    Class *clsPtr;
+    Tcl_Method method;
+    int bodyLength;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "body");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+
+    Tcl_GetStringFromObj(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 == NULL) {
+	    return TCL_ERROR;
+	}
+    } else {
+	/*
+	 * Delete the destructor method record and set the field in the class
+	 * record to NULL.
+	 */
+
+	method = NULL;
+    }
+
+    /*
+     * Place the method structure in the class record. Note that we might not
+     * immediately delete the destructor as this might be being done during
+     * execution of the destructor itself. Also note that setting a
+     * destructor during a destructor is fairly dumb anyway.
+     */
+
+    Tcl_ClassSetDestructor(interp, (Tcl_Class) clsPtr, method);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineExportObjCmd --
+ *	Implementation of the "export" subcommand of the "oo::define" and
+ *	"oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineExportObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceExport = (clientData != NULL);
+    Object *oPtr;
+    Method *mPtr;
+    Tcl_HashEntry *hPtr;
+    Class *clsPtr;
+    int i, isNew, changed = 0;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+    if (!isInstanceExport && !clsPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	return TCL_ERROR;
+    }
+
+    for (i=1 ; i<objc ; i++) {
+	/*
+	 * Exporting is done by adding the PUBLIC_METHOD flag to the method
+	 * record. If there is no such method in this object or class (i.e.
+	 * the method comes from something inherited from or that we're an
+	 * instance of) then we put in a blank record with that flag; such
+	 * records are skipped over by the call chain engine *except* for
+	 * their flags member.
+	 */
+
+	if (isInstanceExport) {
+	    if (!oPtr->methodsPtr) {
+		oPtr->methodsPtr = (Tcl_HashTable *)
+			ckalloc(sizeof(Tcl_HashTable));
+		Tcl_InitObjHashTable(oPtr->methodsPtr);
+		oPtr->flags &= ~USE_CLASS_CACHE;
+	    }
+	    hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
+		    &isNew);
+	} else {
+	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+		    &isNew);
+	}
+
+	if (isNew) {
+	    mPtr = (Method *) ckalloc(sizeof(Method));
+	    memset(mPtr, 0, sizeof(Method));
+	    Tcl_SetHashValue(hPtr, mPtr);
+	} else {
+	    mPtr = Tcl_GetHashValue(hPtr);
+	}
+	if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
+	    mPtr->flags |= PUBLIC_METHOD;
+	    changed = 1;
+	}
+    }
+
+    /*
+     * Bump the right epoch if we actually changed anything.
+     */
+
+    if (changed) {
+	if (isInstanceExport) {
+	    oPtr->epoch++;
+	} else {
+	    BumpGlobalEpoch(interp, clsPtr);
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineFilterObjCmd --
+ *	Implementation of the "filter" subcommand of the "oo::define" and
+ *	"oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineFilterObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceFilter = (clientData != NULL);
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (!isInstanceFilter && !oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	return TCL_ERROR;
+    }
+
+    if (!isInstanceFilter) {
+	TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1);
+    } else {
+	TclOOObjectSetFilters(oPtr, objc-1, objv+1);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineForwardObjCmd --
+ *	Implementation of the "forward" subcommand of the "oo::define" and
+ *	"oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineForwardObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceForward = (clientData != NULL);
+    Object *oPtr;
+    Method *mPtr;
+    int isPublic;
+    Tcl_Obj *prefixObj;
+
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (!isInstanceForward && !oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	return TCL_ERROR;
+    }
+    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+	    ? PUBLIC_METHOD : 0;
+
+    /*
+     * Create the method structure.
+     */
+
+    prefixObj = Tcl_NewListObj(objc-2, objv+2);
+    if (isInstanceForward) {
+	mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1],
+		prefixObj);
+    } else {
+	mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic,
+		objv[1], prefixObj);
+    }
+    if (mPtr == NULL) {
+	Tcl_DecrRefCount(prefixObj);
+	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineMethodObjCmd --
+ *	Implementation of the "method" subcommand of the "oo::define" and
+ *	"oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineMethodObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceMethod = (clientData != NULL);
+    Object *oPtr;
+    int isPublic;
+
+    if (objc != 4) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (!isInstanceMethod && !oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	return TCL_ERROR;
+    }
+    isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
+	    ? PUBLIC_METHOD : 0;
+
+    /*
+     * Create the method by using the right back-end API.
+     */
+
+    if (isInstanceMethod) {
+	if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
+		objv[2], objv[3], NULL) == NULL) {
+	    return TCL_ERROR;
+	}
+    } else {
+	if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1],
+		objv[2], objv[3], NULL) == NULL) {
+	    return TCL_ERROR;
+	}
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineMixinObjCmd --
+ *	Implementation of the "mixin" subcommand of the "oo::define" and
+ *	"oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineMixinObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    const int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceMixin = (clientData != NULL);
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Class **mixins;
+    int i;
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (!isInstanceMixin && !oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	return TCL_ERROR;
+    }
+    mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
+
+    for (i=1 ; i<objc ; i++) {
+	Object *o2Ptr;
+
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
+	if (o2Ptr == NULL) {
+	    goto freeAndError;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "may only mix in classes; \"",
+		    TclGetString(objv[i]), "\" is not a class", NULL);
+	    goto freeAndError;
+	}
+	if (!isInstanceMixin &&
+		TclOOIsReachable(oPtr->classPtr,o2Ptr->classPtr)){
+	    Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+	    goto freeAndError;
+	}
+	mixins[i-1] = o2Ptr->classPtr;
+    }
+
+    if (isInstanceMixin) {
+	TclOOObjectSetMixins(oPtr, objc-1, mixins);
+    } else {
+	TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
+    }
+
+    TclStackFree(interp, mixins);
+    return TCL_OK;
+
+  freeAndError:
+    TclStackFree(interp, mixins);
+    return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineRenameMethodObjCmd --
+ *	Implementation of the "renamemethod" subcommand of the "oo::define"
+ *	and "oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineRenameMethodObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceRenameMethod = (clientData != NULL);
+    Object *oPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (!isInstanceRenameMethod && !oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", 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
+     * get the entries from the appropriate hash tables (this can generate a
+     * range of errors...)
+     */
+
+    if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod,
+	    objv[1], objv[2]) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    if (isInstanceRenameMethod) {
+	oPtr->epoch++;
+    } else {
+	BumpGlobalEpoch(interp, oPtr->classPtr);
+    }
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSuperclassObjCmd --
+ *	Implementation of the "superclass" subcommand of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSuperclassObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr, *o2Ptr;
+    Foundation *fPtr = TclOOGetFoundation(interp);
+    Class **superclasses, *superPtr;
+    int i, j;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
+	return TCL_ERROR;
+    }
+
+    /*
+     * Get the class to operate on.
+     */
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (oPtr->classPtr == NULL) {
+	Tcl_AppendResult(interp, "only classes may have superclasses defined",
+		NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == fPtr->objectCls->thisPtr) {
+	Tcl_AppendResult(interp,
+		"may not modify the superclass of the root object", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Allocate some working space.
+     */
+
+    superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+
+    /*
+     * Parse the arguments to get the class to use as superclasses.
+     */
+
+    for (i=0 ; i<objc-1 ; i++) {
+	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i+1]);
+	if (o2Ptr == NULL) {
+	    goto failedAfterAlloc;
+	}
+	if (o2Ptr->classPtr == NULL) {
+	    Tcl_AppendResult(interp, "only a class can be a superclass",NULL);
+	    goto failedAfterAlloc;
+	}
+	for (j=0 ; j<i ; j++) {
+	    if (superclasses[j] == o2Ptr->classPtr) {
+		Tcl_AppendResult(interp,
+			"class should only be a direct superclass once",NULL);
+		goto failedAfterAlloc;
+	    }
+	}
+	if (TclOOIsReachable(oPtr->classPtr, o2Ptr->classPtr)) {
+	    Tcl_AppendResult(interp,
+		    "attempt to form circular dependency graph", NULL);
+	failedAfterAlloc:
+	    ckfree((char *) superclasses);
+	    return TCL_ERROR;
+	}
+	superclasses[i] = o2Ptr->classPtr;
+    }
+
+    /*
+     * Install the list of superclasses into the class. Note that this also
+     * involves splicing the class out of the superclasses' subclass list that
+     * it used to be a member of and splicing it into the new superclasses'
+     * subclass list.
+     */
+
+    if (oPtr->classPtr->superclasses.num != 0) {
+	FOREACH(superPtr, oPtr->classPtr->superclasses) {
+	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+	}
+	ckfree((char *) oPtr->classPtr->superclasses.list);
+    }
+    oPtr->classPtr->superclasses.list = superclasses;
+    oPtr->classPtr->superclasses.num = objc-1;
+    FOREACH(superPtr, oPtr->classPtr->superclasses) {
+	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+    }
+    BumpGlobalEpoch(interp, oPtr->classPtr);
+
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineUnexportObjCmd --
+ *	Implementation of the "unexport" subcommand of the "oo::define" and
+ *	"oo::objdefine" commands.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineUnexportObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    int isInstanceUnexport = (clientData != NULL);
+    Object *oPtr;
+    Method *mPtr;
+    Tcl_HashEntry *hPtr;
+    Class *clsPtr;
+    int i, isNew, changed = 0;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+	return TCL_ERROR;
+    }
+
+    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    clsPtr = oPtr->classPtr;
+    if (!isInstanceUnexport && !clsPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	return TCL_ERROR;
+    }
+
+    for (i=1 ; i<objc ; i++) {
+	/*
+	 * Unexporting is done by removing the PUBLIC_METHOD flag from the
+	 * method record. If there is no such method in this object or class
+	 * (i.e. the method comes from something inherited from or that we're
+	 * an instance of) then we put in a blank record without that flag;
+	 * such records are skipped over by the call chain engine *except* for
+	 * their flags member.
+	 */
+
+	if (isInstanceUnexport) {
+	    if (!oPtr->methodsPtr) {
+		oPtr->methodsPtr = (Tcl_HashTable *)
+			ckalloc(sizeof(Tcl_HashTable));
+		Tcl_InitObjHashTable(oPtr->methodsPtr);
+		oPtr->flags &= ~USE_CLASS_CACHE;
+	    }
+	    hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
+		    &isNew);
+	} else {
+	    hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
+		    &isNew);
+	}
+
+	if (isNew) {
+	    mPtr = (Method *) ckalloc(sizeof(Method));
+	    memset(mPtr, 0, sizeof(Method));
+	    Tcl_SetHashValue(hPtr, mPtr);
+	} else {
+	    mPtr = Tcl_GetHashValue(hPtr);
+	}
+	if (isNew || mPtr->flags & PUBLIC_METHOD) {
+	    mPtr->flags &= ~PUBLIC_METHOD;
+	    changed = 1;
+	}
+    }
+
+    /*
+     * Bump the right epoch if we actually changed anything.
+     */
+
+    if (changed) {
+	if (isInstanceUnexport) {
+	    oPtr->epoch++;
+	} else {
+	    BumpGlobalEpoch(interp, clsPtr);
+	}
+    }
+    return TCL_OK;
+}
+
+void
+Tcl_ClassSetConstructor(
+    Tcl_Interp *interp,
+    Tcl_Class clazz,
+    Tcl_Method method)
+{
+    Class *clsPtr = (Class *) clazz;
+
+    if (method != (Tcl_Method) clsPtr->constructorPtr) {
+	TclOODelMethodRef(clsPtr->constructorPtr);
+	clsPtr->constructorPtr = (Method *) method;
+	BumpGlobalEpoch(interp, clsPtr);
+    }
+}
+
+void
+Tcl_ClassSetDestructor(
+    Tcl_Interp *interp,
+    Tcl_Class clazz,
+    Tcl_Method method)
+{
+    Class *clsPtr = (Class *) clazz;
+
+    if (method != (Tcl_Method) clsPtr->destructorPtr) {
+	TclOODelMethodRef(clsPtr->destructorPtr);
+	clsPtr->destructorPtr = (Method *) method;
+	BumpGlobalEpoch(interp, clsPtr);
+    }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */