diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 1008 |
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; } /* |