summaryrefslogtreecommitdiffstats
path: root/generic/tclOODefineCmds.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2012-03-26 12:51:15 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2012-03-26 12:51:15 (GMT)
commitd23835257d7cdbf7c914e23117f34386a03420f4 (patch)
tree1db6e1428e872a9de7d6e17956bad4dcfeeba688 /generic/tclOODefineCmds.c
parent1ca58edee5cf1e80b4755b2cb99c405bcd1dac67 (diff)
downloadtcl-d23835257d7cdbf7c914e23117f34386a03420f4.zip
tcl-d23835257d7cdbf7c914e23117f34386a03420f4.tar.gz
tcl-d23835257d7cdbf7c914e23117f34386a03420f4.tar.bz2
Implementation of TIP #380
Diffstat (limited to 'generic/tclOODefineCmds.c')
-rw-r--r--generic/tclOODefineCmds.c1008
1 files changed, 793 insertions, 215 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 72732da..e986326 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -17,6 +17,23 @@
#include "tclOOInt.h"
/*
+ * Some things that make it easier to declare a slot.
+ */
+
+struct DeclaredSlot {
+ const char *name;
+ const Tcl_MethodType getterType;
+ const Tcl_MethodType setterType;
+};
+
+#define SLOT(name,getter,setter) \
+ {"::oo::" name, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
+ getter, NULL, NULL}, \
+ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
+ setter, NULL, NULL}}
+
+/*
* Forward declarations.
*/
@@ -32,6 +49,63 @@ static inline void RecomputeClassCacheFlag(Object *oPtr);
static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
int useClass, Tcl_Obj *const fromPtr,
Tcl_Obj *const toPtr);
+static int ClassFilterGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassFilterSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassMixinGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassMixinSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassSuperGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassSuperSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassVarsGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ClassVarsSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjFilterGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjFilterSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjMixinGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjMixinSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjVarsGet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+static int ObjVarsSet(ClientData clientData,
+ Tcl_Interp *interp, Tcl_ObjectContext context,
+ int objc, Tcl_Obj *const *objv);
+
+/*
+ * Now define the slots used in declarations.
+ */
+
+static const struct DeclaredSlot slots[] = {
+ SLOT("define::filter", ClassFilterGet, ClassFilterSet),
+ SLOT("define::mixin", ClassMixinGet, ClassMixinSet),
+ SLOT("define::superclass", ClassSuperGet, ClassSuperSet),
+ SLOT("define::variable", ClassVarsGet, ClassVarsSet),
+ SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet),
+ SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet),
+ SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet),
+ {NULL}
+};
/*
* ----------------------------------------------------------------------
@@ -1388,43 +1462,6 @@ TclOODefineExportObjCmd(
/*
* ----------------------------------------------------------------------
*
- * 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);
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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.
@@ -1656,84 +1693,484 @@ TclOODefineRenameMethodObjCmd(
/*
* ----------------------------------------------------------------------
*
- * TclOODefineSuperclassObjCmd --
- * Implementation of the "superclass" subcommand of the "oo::define"
- * command.
+ * TclOODefineUnexportObjCmd --
+ * Implementation of the "unexport" subcommand of the "oo::define" and
+ * "oo::objdefine" commands.
*
* ----------------------------------------------------------------------
*/
int
-TclOODefineSuperclassObjCmd(
+TclOODefineUnexportObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
+ int isInstanceUnexport = (clientData != NULL);
Object *oPtr;
- Class **superclasses, *superPtr;
- int i, j;
+ Method *mPtr;
+ Tcl_HashEntry *hPtr;
+ Class *clsPtr;
+ int i, isNew, changed = 0;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
+ 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);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i=1 ; i<objc ; i++) {
+ /*
+ * Unexporting is done by removing the PUBLIC_METHOD flag from the
+ * method record. If there is no such method in this object or class
+ * (i.e. the method comes from something inherited from or that we're
+ * an instance of) then we put in a blank record without that flag;
+ * such records are skipped over by the call chain engine *except* for
+ * their flags member.
+ */
+
+ if (isInstanceUnexport) {
+ if (!oPtr->methodsPtr) {
+ oPtr->methodsPtr = 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 = ckalloc(sizeof(Method));
+ memset(mPtr, 0, sizeof(Method));
+ mPtr->refCount = 1;
+ mPtr->namePtr = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ Tcl_SetHashValue(hPtr, mPtr);
+ } else {
+ mPtr = Tcl_GetHashValue(hPtr);
+ }
+ if (isNew || mPtr->flags & PUBLIC_METHOD) {
+ mPtr->flags &= ~PUBLIC_METHOD;
+ changed = 1;
+ }
+ }
+
/*
- * Get the class to operate on.
+ * Bump the right epoch if we actually changed anything.
*/
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ if (changed) {
+ if (isInstanceUnexport) {
+ oPtr->epoch++;
+ } else {
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ * How to install a constructor or destructor into a class; API to call
+ * from C.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+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;
+
+ /*
+ * Remember to invalidate the cached constructor chain for this class.
+ * [Bug 2531577]
+ */
+
+ if (clsPtr->constructorChainPtr) {
+ TclOODeleteChain(clsPtr->constructorChainPtr);
+ clsPtr->constructorChainPtr = NULL;
+ }
+ 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;
+ if (clsPtr->destructorChainPtr) {
+ TclOODeleteChain(clsPtr->destructorChainPtr);
+ clsPtr->destructorChainPtr = NULL;
+ }
+ BumpGlobalEpoch(interp, clsPtr);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSlots --
+ * Create the "::oo::Slot" class and its standard instances. Class
+ * definition is empty at the stage (added by scripting).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSlots(
+ Foundation *fPtr)
+{
+ const struct DeclaredSlot *slotInfoPtr;
+ Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
+ Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+ Class *slotCls;
+
+ slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
+ fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr;
+ if (slotCls == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(getName);
+ Tcl_IncrRefCount(setName);
+ for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
+ Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
+ (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);
+
+ if (slotObject == NULL) {
+ continue;
+ }
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+ &slotInfoPtr->getterType, NULL);
+ Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+ &slotInfoPtr->setterType, NULL);
+ }
+ Tcl_DecrRefCount(getName);
+ Tcl_DecrRefCount(setName);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassFilterGet, ClassFilterSet --
+ * Implementation of the "filter" slot accessors of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassFilterGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *filterObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
if (oPtr == NULL) {
return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
}
- if (oPtr->classPtr == NULL) {
- Tcl_AppendResult(interp, "only classes may have superclasses defined",
+
+ resultObj = Tcl_NewObj();
+ FOREACH(filterObj, oPtr->classPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassFilterSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int filterc;
+ Tcl_Obj **filterv;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+ &filterv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassMixinGet, ClassMixinSet --
+ * Implementation of the "mixin" slot accessors of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassMixinGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *mixinPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
NULL);
- Tcl_SetErrorCode(interp, "TCL", "OO", "OBJECT_NOT_CLASS", NULL);
return TCL_ERROR;
}
- if (oPtr->flags & ROOT_OBJECT) {
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, oPtr->classPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+
+}
+
+static int
+ClassMixinSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int mixinc, i;
+ Tcl_Obj **mixinv;
+ Class **mixins;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "mixinList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+ &mixinv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+ for (i=0 ; i<mixinc ; i++) {
+ mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+ "may only mix in classes");
+ if (mixins[i] == NULL) {
+ goto freeAndError;
+ }
+ if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
+ Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
+ goto freeAndError;
+ }
+ }
+
+ TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+ TclStackFree(interp, mixins);
+ return TCL_OK;
+
+ freeAndError:
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassSuperGet, ClassSuperSet --
+ * Implementation of the "superclass" slot accessors of the "oo::define"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassSuperGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *superPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ }
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(superPtr, oPtr->classPtr->superclasses) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, superPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassSuperSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int superc, i, j;
+ Tcl_Obj **superv;
+ Class **superclasses, *superPtr;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "superclassList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
+ } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
Tcl_AppendResult(interp,
"may not modify the superclass of the root object", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
+ &superv) != TCL_OK) {
+ return TCL_ERROR;
}
/*
* Allocate some working space.
*/
- superclasses = ckalloc(sizeof(Class *) * (objc-1));
+ superclasses = (Class **) ckalloc(sizeof(Class *) * superc);
/*
* Parse the arguments to get the class to use as superclasses.
*/
- for (i=0 ; i<objc-1 ; i++) {
- Class *clsPtr = GetClassInOuterContext(interp, objv[i+1],
+ for (i=0 ; i<superc ; i++) {
+ superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
-
- if (clsPtr == NULL) {
+ if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
for (j=0 ; j<i ; j++) {
- if (superclasses[j] == clsPtr) {
+ if (superclasses[j] == superclasses[i]) {
Tcl_AppendResult(interp,
"class should only be a direct superclass once",NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
goto failedAfterAlloc;
}
}
- if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
+ if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
Tcl_AppendResult(interp,
"attempt to form circular dependency graph", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
- ckfree(superclasses);
+ ckfree((char *) superclasses);
return TCL_ERROR;
}
- superclasses[i] = clsPtr;
}
/*
@@ -1747,10 +2184,10 @@ TclOODefineSuperclassObjCmd(
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
}
- ckfree(oPtr->classPtr->superclasses.list);
+ ckfree((char *) oPtr->classPtr->superclasses.list);
}
oPtr->classPtr->superclasses.list = superclasses;
- oPtr->classPtr->superclasses.num = objc-1;
+ oPtr->classPtr->superclasses.num = superc;
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOOAddToSubclasses(oPtr->classPtr, superPtr);
}
@@ -1762,129 +2199,336 @@ TclOODefineSuperclassObjCmd(
/*
* ----------------------------------------------------------------------
*
- * TclOODefineUnexportObjCmd --
- * Implementation of the "unexport" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
+ * ClassVarsGet, ClassVarsSet --
+ * Implementation of the "variable" slot accessors of the "oo::define"
+ * command.
*
* ----------------------------------------------------------------------
*/
-int
-TclOODefineUnexportObjCmd(
+static int
+ClassVarsGet(
ClientData clientData,
Tcl_Interp *interp,
+ Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- int isInstanceUnexport = (clientData != NULL);
- Object *oPtr;
- Method *mPtr;
- Tcl_HashEntry *hPtr;
- Class *clsPtr;
- int i, isNew, changed = 0;
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *variableObj;
+ int i;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
return TCL_ERROR;
}
-
- oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
+ Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+ return TCL_ERROR;
}
- clsPtr = oPtr->classPtr;
- if (!isInstanceUnexport && !clsPtr) {
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ClassVarsSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc;
+ Tcl_Obj **varv, *variableObj;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ } else if (!oPtr->classPtr) {
Tcl_AppendResult(interp, "attempt to misuse API", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
+ } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
+ return TCL_ERROR;
}
- for (i=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.
- */
+ for (i=0 ; i<varc ; i++) {
+ const char *varName = Tcl_GetString(varv[i]);
- if (isInstanceUnexport) {
- if (!oPtr->methodsPtr) {
- oPtr->methodsPtr = 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 (strstr(varName, "::") != NULL) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not contain namespace separators",
+ NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ return TCL_ERROR;
}
+ if (Tcl_StringMatch(varName, "*(*)")) {
+ Tcl_AppendResult(interp, "invalid declared variable name \"",
+ varName, "\": must not refer to an array element", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+ return TCL_ERROR;
+ }
+ }
- if (isNew) {
- mPtr = ckalloc(sizeof(Method));
- memset(mPtr, 0, sizeof(Method));
- mPtr->refCount = 1;
- mPtr->namePtr = objv[i];
- Tcl_IncrRefCount(objv[i]);
- Tcl_SetHashValue(hPtr, mPtr);
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
+ }
+ FOREACH(variableObj, oPtr->classPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
+ }
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree((char *) oPtr->classPtr->variables.list);
+ } else if (i) {
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->classPtr->variables.list,
+ sizeof(Tcl_Obj *) * varc);
} else {
- mPtr = Tcl_GetHashValue(hPtr);
- }
- if (isNew || mPtr->flags & PUBLIC_METHOD) {
- mPtr->flags &= ~PUBLIC_METHOD;
- changed = 1;
+ oPtr->classPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * varc);
}
}
+ if (varc > 0) {
+ memcpy(oPtr->classPtr->variables.list, varv,
+ sizeof(Tcl_Obj *) * varc);
+ }
+ oPtr->classPtr->variables.num = varc;
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectFilterGet, ObjectFilterSet --
+ * Implementation of the "filter" slot accessors of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
- /*
- * Bump the right epoch if we actually changed anything.
- */
+static int
+ObjFilterGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj, *filterObj;
+ int i;
- if (changed) {
- if (isInstanceUnexport) {
- oPtr->epoch++;
- } else {
- BumpGlobalEpoch(interp, clsPtr);
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(filterObj, oPtr->filters) {
+ Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjFilterSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int filterc;
+ Tcl_Obj **filterv;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "filterList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+ &filterv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ TclOOObjectSetFilters(oPtr, filterc, filterv);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectMixinGet, ObjectMixinSet --
+ * Implementation of the "mixin" slot accessors of the "oo::objdefine"
+ * command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjMixinGet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ Tcl_Obj *resultObj;
+ Class *mixinPtr;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ resultObj = Tcl_NewObj();
+ FOREACH(mixinPtr, oPtr->mixins) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjMixinSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int mixinc;
+ Tcl_Obj **mixinv;
+ Class **mixins;
+ int i;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "mixinList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+ &mixinv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+ for (i=0 ; i<mixinc ; i++) {
+ mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+ "may only mix in classes");
+ if (mixins[i] == NULL) {
+ TclStackFree(interp, mixins);
+ return TCL_ERROR;
}
}
+
+ TclOOObjectSetMixins(oPtr, mixinc, mixins);
+ TclStackFree(interp, mixins);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
- * TclOODefineVariablesObjCmd --
- * Implementation of the "variable" subcommand of the "oo::define" and
- * "oo::objdefine" commands.
+ * ObjectVarsGet, ObjectVarsSet --
+ * Implementation of the "variable" slot accessors of the "oo::objdefine"
+ * command.
*
* ----------------------------------------------------------------------
*/
-int
-TclOODefineVariablesObjCmd(
+static int
+ObjVarsGet(
ClientData clientData,
Tcl_Interp *interp,
+ Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
- int isInstanceVars = (clientData != NULL);
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- Tcl_Obj *variableObj;
+ Tcl_Obj *resultObj, *variableObj;
int i;
- if (oPtr == NULL) {
+ if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ NULL);
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
return TCL_ERROR;
}
- if (!isInstanceVars && !oPtr->classPtr) {
- Tcl_AppendResult(interp, "attempt to misuse API", NULL);
- Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+
+ resultObj = Tcl_NewObj();
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+static int
+ObjVarsSet(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+ int varc, i;
+ Tcl_Obj **varv, *variableObj;
+
+ if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+ Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+ "variableList");
+ return TCL_ERROR;
+ } else if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
+ objv += Tcl_ObjectContextSkippedArgs(context);
+ if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+ &varv) != TCL_OK) {
return TCL_ERROR;
}
- for (i=1 ; i<objc ; i++) {
- const char *varName = Tcl_GetString(objv[i]);
+ for (i=0 ; i<varc ; i++) {
+ const char *varName = Tcl_GetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_AppendResult(interp, "invalid declared variable name \"",
@@ -1900,96 +2544,30 @@ TclOODefineVariablesObjCmd(
return TCL_ERROR;
}
}
- for (i=1 ; i<objc ; i++) {
- Tcl_IncrRefCount(objv[i]);
+ for (i=0 ; i<varc ; i++) {
+ Tcl_IncrRefCount(varv[i]);
}
- if (!isInstanceVars) {
- FOREACH(variableObj, oPtr->classPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != objc-1) {
- if (objc == 1) {
- ckfree(oPtr->classPtr->variables.list);
- } else if (i) {
- oPtr->classPtr->variables.list =
- ckrealloc(oPtr->classPtr->variables.list,
- sizeof(Tcl_Obj *) * (objc-1));
- } else {
- oPtr->classPtr->variables.list =
- ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- }
- }
- if (objc > 1) {
- memcpy(oPtr->classPtr->variables.list, objv+1,
- sizeof(Tcl_Obj *) * (objc-1));
- }
- oPtr->classPtr->variables.num = objc-1;
- } else {
- FOREACH(variableObj, oPtr->variables) {
- Tcl_DecrRefCount(variableObj);
- }
- if (i != objc-1) {
- if (objc == 1) {
- ckfree(oPtr->variables.list);
- } else if (i) {
- oPtr->variables.list = ckrealloc(oPtr->variables.list,
- sizeof(Tcl_Obj *) * (objc-1));
- } else {
- oPtr->variables.list =
- ckalloc(sizeof(Tcl_Obj *) * (objc-1));
- }
- }
- if (objc > 1) {
- memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1));
- }
- oPtr->variables.num = objc-1;
+ FOREACH(variableObj, oPtr->variables) {
+ Tcl_DecrRefCount(variableObj);
}
- 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;
-
- /*
- * Remember to invalidate the cached constructor chain for this class.
- * [Bug 2531577]
- */
-
- if (clsPtr->constructorChainPtr) {
- TclOODeleteChain(clsPtr->constructorChainPtr);
- clsPtr->constructorChainPtr = NULL;
+ if (i != varc) {
+ if (varc == 0) {
+ ckfree((char *) oPtr->variables.list);
+ } else if (i) {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckrealloc((char *) oPtr->variables.list,
+ sizeof(Tcl_Obj *) * varc);
+ } else {
+ oPtr->variables.list = (Tcl_Obj **)
+ ckalloc(sizeof(Tcl_Obj *) * varc);
}
- 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;
- if (clsPtr->destructorChainPtr) {
- TclOODeleteChain(clsPtr->destructorChainPtr);
- clsPtr->destructorChainPtr = NULL;
- }
- BumpGlobalEpoch(interp, clsPtr);
+ if (varc > 0) {
+ memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc);
}
+ oPtr->variables.num = varc;
+ return TCL_OK;
}
/*