summaryrefslogtreecommitdiffstats
path: root/generic/tclOODefineCmds.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOODefineCmds.c')
-rw-r--r--generic/tclOODefineCmds.c953
1 files changed, 0 insertions, 953 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
deleted file mode 100644
index 9f2635b..0000000
--- a/generic/tclOODefineCmds.c
+++ /dev/null
@@ -1,953 +0,0 @@
-/*
- * 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 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.2 2006/10/20 14:04:01 dkf Exp $
- */
-
-#include "tclInt.h"
-#include "tclOO.h"
-
-static Object * GetDefineCmdContext(Tcl_Interp *interp);
-
-int
-TclOODefineObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- CallFrame *framePtr, **framePtrPtr;
- Foundation *fPtr = ((Interp *) interp)->ooFoundation;
- 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::define namespace the current namespace and evaluate the
- * command(s).
- */
-
- /* This is needed to satisfy GCC 3.3's strict aliasing rules */
- framePtrPtr = &framePtr;
- result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
- (Tcl_Namespace *) fPtr->defineNs, FRAME_IS_OO_DEFINE);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
- framePtr->ooContextPtr = oPtr;
- framePtr->objc = objc;
- framePtr->objv = objv; /* Reference counts do not need to be
- * incremented here. */
-
- if (objc == 3) {
- result = Tcl_EvalObjEx(interp, objv[2], 0);
-
- if (result == TCL_ERROR) {
- int length;
- const char *objName = Tcl_GetStringFromObj(objv[1], &length);
- int limit = 200;
- int overflow = (length > limit);
-
- TclFormatToErrorInfo(interp,
- "\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.
- */
-
- TclNewObj(objPtr);
- TclNewObj(obj2Ptr);
- cmd = Tcl_FindCommand(interp, TclGetString(objv[2]), fPtr->defineNs,
- TCL_NAMESPACE_ONLY);
- 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);
- TclDecrRefCount(objPtr);
- }
-
- /*
- * Restore the previous "current" namespace.
- */
-
- TclPopStackFrame(interp);
- return result;
-}
-
-static Object *
-GetDefineCmdContext(
- 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 the ::oo::define command", NULL);
- return NULL;
- }
- return (Object *) iPtr->framePtr->ooContextPtr;
-}
-
-int
-TclOODefineConstructorObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr;
- Class *clsPtr;
- 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 = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have constructors defined",
- NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
-
- (void) Tcl_GetStringFromObj(objv[2], &bodyLength);
- if (bodyLength > 0) {
- /*
- * Create the method structure.
- */
-
- Method *mPtr;
-
- mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, objv[1],
- objv[2]);
- if (mPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * 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.
- */
-
- TclOODeleteMethod(clsPtr->constructorPtr);
- clsPtr->constructorPtr = mPtr;
- } else {
- /*
- * Delete the constructor method record and set the field in the class
- * record to NULL.
- */
-
- TclOODeleteMethod(clsPtr->constructorPtr);
- clsPtr->constructorPtr = NULL;
- }
-
- return TCL_OK;
-}
-
-int
-TclOODefineCopyObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Tcl_Object oPtr, o2Ptr;
-
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?targetName?");
- return TCL_ERROR;
- }
-
- oPtr = (Tcl_Object) GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- 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,
- * but rather in the context of the namespace of the caller of the overall
- * [oo::define] command.
- */
-
- if (objc == 1) {
- o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL);
- } else {
- char *name;
- Tcl_DString buffer;
-
- name = TclGetString(objv[1]);
- Tcl_DStringInit(&buffer);
- if (name[0]!=':' || name[1]!=':') {
- Interp *iPtr = (Interp *) interp;
- CallFrame *callerFramePtr = iPtr->varFramePtr->callerVarPtr;
-
- if (callerFramePtr != NULL) {
- Tcl_DStringAppend(&buffer,
- callerFramePtr->nsPtr->fullName, -1);
- }
- Tcl_DStringAppend(&buffer, "::", 2);
- Tcl_DStringAppend(&buffer, name, -1);
- name = Tcl_DStringValue(&buffer);
- }
- o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name);
- Tcl_DStringFree(&buffer);
- }
-
- if (o2Ptr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Return the name of the cloned object.
- */
-
- Tcl_GetCommandFullName(interp, Tcl_GetObjectCommand(o2Ptr),
- Tcl_GetObjResult(interp));
- return TCL_OK;
-}
-
-int
-TclOODefineDestructorObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr;
- Class *clsPtr;
- int bodyLength;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "body");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have destructors defined",
- NULL);
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
-
- (void) Tcl_GetStringFromObj(objv[1], &bodyLength);
- if (bodyLength > 0) {
- /*
- * Create the method structure.
- */
-
- Method *mPtr;
-
- mPtr = TclOONewProcClassMethod(interp, clsPtr, 1, NULL, NULL,
- objv[1]);
- if (mPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * 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.
- */
-
- TclOODeleteMethod(clsPtr->destructorPtr);
- clsPtr->destructorPtr = mPtr;
- } else {
- /*
- * Delete the destructor method record and set the field in the class
- * record to NULL.
- */
-
- TclOODeleteMethod(clsPtr->destructorPtr);
- clsPtr->destructorPtr = NULL;
- }
-
- return TCL_OK;
-}
-
-int
-TclOODefineExportObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfExport = (clientData != NULL);
- Object *oPtr;
- Method *mPtr;
- Tcl_HashEntry *hPtr;
- Class *clsPtr;
- int i, isNew;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
- isSelfExport |= (clsPtr == NULL);
-
- for (i=1 ; i<objc ; i++) {
- if (isSelfExport) {
- hPtr = Tcl_CreateHashEntry(&oPtr->methods, (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);
- }
- mPtr->flags |= PUBLIC_METHOD;
- }
- if (isSelfExport) {
- oPtr->epoch++;
- } else {
- ((Interp *)interp)->ooFoundation->epoch++;
- }
- return TCL_OK;
-}
-
-int
-TclOODefineFilterObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfFilter = (clientData != NULL);
- Object *oPtr;
- int i;
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfFilter |= (oPtr->classPtr == NULL);
-
- if (!isSelfFilter) {
- if (oPtr->classPtr->filters.num) {
- Tcl_Obj *filterObj;
-
- FOREACH(filterObj, oPtr->classPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- }
-
- if (objc == 1) {
- // deleting filters
- ckfree((char *) oPtr->classPtr->filters.list);
- oPtr->classPtr->filters.list = NULL;
- oPtr->classPtr->filters.num = 0;
- } else {
- // creating filters
- Tcl_Obj **filters;
-
- if (oPtr->classPtr->filters.num == 0) {
- filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- } else {
- filters = (Tcl_Obj **) ckrealloc(
- (char *) oPtr->classPtr->filters.list,
- sizeof(Tcl_Obj *) * (objc-1));
- }
- for (i=1 ; i<objc ; i++) {
- filters[i-1] = objv[i];
- Tcl_IncrRefCount(objv[i]);
- }
- oPtr->classPtr->filters.list = filters;
- oPtr->classPtr->filters.num = objc-1;
- }
- // may be many objects affected
- ((Interp *)interp)->ooFoundation->epoch++;
- } else {
- if (oPtr->filters.num) {
- Tcl_Obj *filterObj;
-
- FOREACH(filterObj, oPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- }
- if (objc == 1) {
- // deleting filters
- ckfree((char *) oPtr->filters.list);
- oPtr->filters.list = NULL;
- oPtr->filters.num = 0;
- } else {
- // creating filters
- Tcl_Obj **filters;
-
- if (oPtr->filters.num == 0) {
- filters = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- } else {
- filters = (Tcl_Obj **) ckrealloc((char *) oPtr->filters.list,
- sizeof(Tcl_Obj *) * (objc-1));
- }
- for (i=1 ; i<objc ; i++) {
- filters[i-1] = objv[i];
- Tcl_IncrRefCount(objv[i]);
- }
- oPtr->filters.list = filters;
- oPtr->filters.num = objc-1;
- }
- oPtr->epoch++; // per-object
- }
- return TCL_OK;
-}
-
-int
-TclOODefineForwardObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfForward = (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 = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfForward |= (oPtr->classPtr == NULL);
- isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
-
- /*
- * Create the method structure.
- */
-
- prefixObj = Tcl_NewListObj(objc-2, objv+2);
- if (isSelfForward) {
- mPtr = TclOONewForwardMethod(interp, oPtr, isPublic, objv[1],
- prefixObj);
- } else {
- mPtr = TclOONewForwardClassMethod(interp, oPtr->classPtr, isPublic,
- objv[1], prefixObj);
- }
- if (mPtr == NULL) {
- TclDecrRefCount(prefixObj);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-int
-TclOODefineMethodObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfMethod = (clientData != NULL);
- Object *oPtr;
- int bodyLength;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "name args body");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfMethod |= (oPtr->classPtr == NULL);
-
- (void) Tcl_GetStringFromObj(objv[3], &bodyLength);
- if (bodyLength > 0) {
- /*
- * Create the method structure.
- */
-
- Method *mPtr;
- int isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*");
-
- if (isSelfMethod) {
- mPtr = TclOONewProcMethod(interp, oPtr, isPublic, objv[1],
- objv[2], objv[3]);
- } else {
- mPtr = TclOONewProcClassMethod(interp, oPtr->classPtr, isPublic,
- objv[1], objv[2], objv[3]);
- }
- if (mPtr == NULL) {
- return TCL_ERROR;
- }
- } else {
- /*
- * Delete the method structure from the appropriate hash table.
- */
-
- Tcl_HashEntry *hPtr;
-
- if (isSelfMethod) {
- hPtr = Tcl_FindHashEntry(&oPtr->methods, (char *)objv[1]);
- } else {
- hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
- (char *)objv[1]);
- }
- if (hPtr != NULL) {
- Method *mPtr = (Method *) Tcl_GetHashValue(hPtr);
-
- Tcl_DeleteHashEntry(hPtr);
- TclOODeleteMethod(mPtr);
- }
- }
-
- return TCL_OK;
-}
-
-int
-TclOODefineMixinObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- const int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfMixin = (clientData != NULL);
- Object *oPtr = GetDefineCmdContext(interp);
- Class *mixinPtr;
- int i;
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- isSelfMixin |= (oPtr->classPtr == NULL);
-
- if (isSelfMixin) {
- if (objc == 1) {
- if (oPtr->mixins.num != 0) {
- FOREACH(mixinPtr, oPtr->mixins) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
- ckfree((char *) oPtr->mixins.list);
- oPtr->mixins.num = 0;
- }
- } else {
- Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
-
- for (i=1 ; i<objc ; i++) {
- Object *o2Ptr;
-
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
- if (o2Ptr == NULL) {
- goto freeAndErrorSelf;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "may only mix in classes; \"",
- TclGetString(objv[i]), "\" is not a class", NULL);
- freeAndErrorSelf:
- ckfree((char *) mixins);
- return TCL_ERROR;
- }
- mixins[i-1] = o2Ptr->classPtr;
- }
- if (oPtr->mixins.num != 0) {
- FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr != oPtr->selfCls) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
- }
- ckfree((char *) oPtr->mixins.list);
- }
- oPtr->mixins.num = objc-1;
- oPtr->mixins.list = mixins;
- FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr != oPtr->selfCls) {
- TclOOAddToInstances(oPtr, mixinPtr);
- }
- }
- }
- oPtr->epoch++;
- } else {
- register Class *clsPtr = oPtr->classPtr;
-
- if (objc == 1) {
- if (clsPtr->mixins.num != 0) {
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
- }
- ckfree((char *) clsPtr->mixins.list);
- clsPtr->mixins.num = 0;
- }
- } else {
- Class **mixins = (Class **) ckalloc(sizeof(Class *) * (objc-1));
-
- for (i=1 ; i<objc ; i++) {
- Object *o2Ptr;
-
- o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[i]);
- if (o2Ptr == NULL) {
- goto freeAndErrorClass;
- }
- if (o2Ptr->classPtr == NULL) {
- Tcl_AppendResult(interp, "may only mix in classes; \"",
- TclGetString(objv[i]), "\" is not a class", NULL);
- freeAndErrorClass:
- ckfree((char *) mixins);
- return TCL_ERROR;
- }
- mixins[i-1] = o2Ptr->classPtr;
- }
- if (clsPtr->mixins.num != 0) {
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
- }
- ckfree((char *) clsPtr->mixins.list);
- }
- clsPtr->mixins.num = objc-1;
- clsPtr->mixins.list = mixins;
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOOAddToMixinSubs(clsPtr, mixinPtr);
- }
- }
- ((Interp *)interp)->ooFoundation->epoch++;
- }
- return TCL_OK;
-}
-
-#ifdef SUPPORT_OO_PARAMETERS
-// Not sure whether we want to retain this in the core oo system since it is
-// easy to add "after market".
-int
-TclOODefineParameterObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr = GetDefineCmdContext(interp);
-
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Must nail down the semantics of this!
- */
-
- Tcl_AppendResult(interp, "TODO: not yet finished", NULL);
- return TCL_ERROR;
-}
-#endif
-
-int
-TclOODefineSelfClassObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr, *o2Ptr;
- Foundation *fPtr = ((Interp *)interp)->ooFoundation;
-
- /*
- * Parse the context to get the object to operate on.
- */
-
- oPtr = GetDefineCmdContext(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) {
- fPtr->epoch++;
- } else {
- oPtr->epoch++;
- }
- }
- return TCL_OK;
-}
-
-int
-TclOODefineSuperclassObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- Object *oPtr, *o2Ptr;
- Foundation *fPtr = ((Interp *)interp)->ooFoundation;
- 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 = GetDefineCmdContext(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);
- }
- fPtr->epoch++;
-
- return TCL_OK;
-}
-
-int
-TclOODefineUnexportObjCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const *objv)
-{
- int isSelfUnexport = (clientData != NULL);
- Object *oPtr;
- Method *mPtr;
- Tcl_HashEntry *hPtr;
- Class *clsPtr;
- int i, isNew;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
- return TCL_ERROR;
- }
-
- oPtr = GetDefineCmdContext(interp);
- if (oPtr == NULL) {
- return TCL_ERROR;
- }
- clsPtr = oPtr->classPtr;
- isSelfUnexport |= (oPtr->classPtr == NULL);
-
- for (i=1 ; i<objc ; i++) {
- if (isSelfUnexport) {
- hPtr = Tcl_CreateHashEntry(&oPtr->methods, (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);
- }
- mPtr->flags &= ~PUBLIC_METHOD;
- }
- if (isSelfUnexport) {
- oPtr->epoch++;
- } else {
- ((Interp *)interp)->ooFoundation->epoch++;
- }
- return TCL_OK;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */