diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 906 |
1 files changed, 797 insertions, 109 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 5ca69e2..e3fbe3f 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,16 +37,27 @@ typedef struct DeclaredSlot { const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; + const char *defaultOp; // The default op, if not set by the class } DeclaredSlot; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter,resolver,defOp) \ {"::oo::" name, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \ getter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \ setter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ - resolver, NULL, NULL}} + {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \ + resolver, NULL, NULL}, (defOp)} + +typedef struct DeclaredSlotMethod { + const char *name; + int flags; + const Tcl_MethodType implType; +} DeclaredSlotMethod; + +#define SLOT_METHOD(name,impl,flags) \ + {name, flags, {TCL_OO_METHOD_VERSION_1, \ + "core method: " name " slot", impl, NULL, NULL}} /* * A [string match] pattern used to determine if a method should be exported. @@ -78,6 +89,33 @@ 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 Slot_Append(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_AppendNew(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Clear(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Prepend(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Remove(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Resolve(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Set(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Unimplemented(void *, + Tcl_Interp *interp, Tcl_ObjectContext, + int, Tcl_Obj *const *); +static int Slot_Unknown(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); static int ClassFilter_Get(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -153,26 +191,40 @@ static int ResolveClass(void *clientData, */ static const DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL), - SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass), - SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass), - SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL), - SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL), - SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass), - SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL), + SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL, NULL), + SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass, "-set"), + SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass, "-set"), + SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL, NULL), + SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL, NULL), + SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass, "-set"), + SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL, NULL), SLOT("configuresupport::readableproperties", Configurable_ClassReadableProps_Get, - Configurable_ClassReadableProps_Set, NULL), + Configurable_ClassReadableProps_Set, NULL, NULL), SLOT("configuresupport::writableproperties", Configurable_ClassWritableProps_Get, - Configurable_ClassWritableProps_Set, NULL), + Configurable_ClassWritableProps_Set, NULL, NULL), SLOT("configuresupport::objreadableproperties", Configurable_ObjectReadableProps_Get, - Configurable_ObjectReadableProps_Set, NULL), + Configurable_ObjectReadableProps_Set, NULL, NULL), SLOT("configuresupport::objwritableproperties", Configurable_ObjectWritableProps_Get, - Configurable_ObjectWritableProps_Set, NULL), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + Configurable_ObjectWritableProps_Set, NULL, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, 0} +}; + +static const DeclaredSlotMethod slotMethods[] = { + SLOT_METHOD("Get", Slot_Unimplemented, 0), + SLOT_METHOD("Resolve", Slot_Resolve, 0), + SLOT_METHOD("Set", Slot_Unimplemented, 0), + SLOT_METHOD("-append", Slot_Append, PUBLIC_METHOD), + SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD), + SLOT_METHOD("-clear", Slot_Clear, PUBLIC_METHOD), + SLOT_METHOD("-prepend", Slot_Prepend, PUBLIC_METHOD), + SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD), + SLOT_METHOD("-set", Slot_Set, PUBLIC_METHOD), + SLOT_METHOD("unknown", Slot_Unknown, 0), + {NULL, 0, {0, 0, 0, 0, 0}} }; /* @@ -1179,6 +1231,119 @@ MagicDefinitionInvoke( /* * ---------------------------------------------------------------------- * + * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod -- + * + * Exporting and unexporting are done by setting or removing the + * PUBLIC_METHOD flag on the method record. If there is no such method in + * this class or object (i.e. the method comes from something inherited + * from or that we're an instance of) then we put in a blank record just + * to hold that flag (or its absence); such records are skipped over by + * the call chain engine *except* for their flags member. + * + * Caller has the responsibility to update any epochs if necessary. + * + * ---------------------------------------------------------------------- + */ + +// Make a blank method record or look up the existing one. +static inline Method * +GetOrCreateMethod( + Tcl_HashTable *tablePtr, + Tcl_Obj *namePtr, + int *isNew) +{ + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr, + isNew); + if (*isNew) { + Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + return mPtr; + } else { + return (Method *) Tcl_GetHashValue(hPtr); + } +} + +static int +ExportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +// Make the table of methods in the instance if it doesn't already exist. +static inline void +InitMethodTable( + Object *oPtr) +{ + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } +} + +static int +ExportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * * Implementation of the "oo::define" command. Works by effectively doing @@ -1887,22 +2052,18 @@ TclOODefineExportObjCmd( Tcl_Obj *const *objv) { int isInstanceExport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } - clsPtr = oPtr->classPtr; + Class *clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", TCL_AUTO_LENGTH)); @@ -1921,33 +2082,9 @@ TclOODefineExportObjCmd( */ if (isInstanceExport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + changed |= ExportInstanceMethod(oPtr, objv[i]); } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { - mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; - changed = 1; + changed |= ExportMethod(clsPtr, objv[i]); } } @@ -2177,6 +2314,72 @@ TclOODefineMethodObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineClassMethodObjCmd -- + * + * Implementation of the "classmethod" subcommand of the "oo::define" + * command. Defines a class method. See define(n) for details. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineClassMethodObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + if (objc != 2 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?"); + return TCL_ERROR; + } + Class *clsPtr = TclOOGetClassDefineCmdContext(interp); + if (!clsPtr) { + return TCL_ERROR; + } + + int isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) + ? PUBLIC_METHOD : 0; + + // Create the method on the delegate class if the caller gave arguments and body + if (objc == 4) { + Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", + clsPtr->thisPtr->namespacePtr->fullName); + Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName); + Tcl_DecrRefCount(delegateName); + if (!delegatePtr) { + return TCL_ERROR; + } + if (IsPrivateDefine(interp)) { + isPublic = 0; + } + if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1], + objv[2], objv[3], NULL) == NULL) { + return TCL_ERROR; + } + } + + // Make the connection to the delegate by forwarding + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } + Tcl_Obj *forwardArgs[] = { + Tcl_NewStringObj("myclass", -1), + objv[1] + }; + Tcl_Obj *prefixObj = Tcl_NewListObj(2, forwardArgs); + Method *mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, + objv[1], prefixObj); + if (mPtr == NULL) { + Tcl_DecrRefCount(prefixObj); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineRenameMethodObjCmd -- * * Implementation of the "renamemethod" subcommand of the "oo::define" @@ -2251,10 +2454,8 @@ TclOODefineUnexportObjCmd( { int isInstanceUnexport = (clientData != NULL); Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); @@ -2274,42 +2475,10 @@ TclOODefineUnexportObjCmd( } 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 *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + changed |= UnexportInstanceMethod(oPtr, objv[i]); } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - changed = 1; + changed |= UnexportMethod(clsPtr, objv[i]); } } @@ -2387,8 +2556,9 @@ Tcl_ClassSetDestructor( * * TclOODefineSlots -- * - * Create the "::oo::Slot" class and its standard instances. Class - * definition is empty at the stage (added by scripting). + * Create the "::oo::Slot" class and its standard instances. These are + * basically lists at the low level of TclOO; this provides a more + * consistent interface to them. * * ---------------------------------------------------------------------- */ @@ -2397,50 +2567,568 @@ int TclOODefineSlots( Foundation *fPtr) { - const DeclaredSlot *slotInfoPtr; Tcl_Interp *interp = fPtr->interp; - Tcl_Obj *getName, *setName, *resolveName; Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0); - Class *slotCls; if (object == NULL) { return TCL_ERROR; } - slotCls = ((Object *) object)->classPtr; + Tcl_Class slotCls = (Tcl_Class) ((Object *) object)->classPtr; if (slotCls == NULL) { return TCL_ERROR; } - TclNewLiteralStringObj(getName, "Get"); - TclNewLiteralStringObj(setName, "Set"); - TclNewLiteralStringObj(resolveName, "Resolve"); - for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { + for (const DeclaredSlotMethod *smPtr = slotMethods; smPtr->name; smPtr++) { + Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1); + Tcl_NewMethod(interp, slotCls, name, smPtr->flags, + &smPtr->implType, NULL); + Tcl_BounceRefCount(name); + } + + // If a slot can't figure out what method to call directly, it uses + // --default-operation. That defaults to -append; we set that here. + Tcl_Obj *defaults[] = { + fPtr->myName, + Tcl_NewStringObj("-append", TCL_AUTO_LENGTH) + }; + TclOONewForwardMethod(interp, (Class *) slotCls, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, defaults)); + + // Hide the destroy method. (We're definitely taking a ref to the name.) + UnexportMethod((Class *) slotCls, + Tcl_NewStringObj("destroy", TCL_AUTO_LENGTH)); + + for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, - NULL, 0); + slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); if (slotObject == NULL) { continue; } - TclNewInstanceMethod(interp, slotObject, getName, 0, - &slotInfoPtr->getterType, NULL); - TclNewInstanceMethod(interp, slotObject, setName, 0, - &slotInfoPtr->setterType, NULL); - if (slotInfoPtr->resolverType.callProc) { - TclNewInstanceMethod(interp, slotObject, resolveName, 0, - &slotInfoPtr->resolverType, NULL); + TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0, + &slotPtr->getterType, NULL); + TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0, + &slotPtr->setterType, NULL); + if (slotPtr->resolverType.callProc) { + TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0, + &slotPtr->resolverType, NULL); + } + if (slotPtr->defaultOp) { + Tcl_Obj *slotDefaults[] = { + fPtr->myName, + Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH) + }; + TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults)); } } - Tcl_BounceRefCount(getName); - Tcl_BounceRefCount(setName); - Tcl_BounceRefCount(resolveName); return TCL_OK; } /* * ---------------------------------------------------------------------- * + * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll -- + * + * How to call the standard low-level methods of a slot. + * ResolveAll is the lifting of CallSlotResolve to work over a whole + * list of items. + * + * ---------------------------------------------------------------------- + */ + +// Call [$slot Get] to retrieve the list of contents of the slot +static inline Tcl_Obj * +CallSlotGet( + Tcl_Interp *interp, + Object *slot) +{ + Tcl_Obj *getArgs[] = { + slot->fPtr->myName, + slot->fPtr->slotGetName + }; + int code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +// Call [$slot Set $list] to set the list of contents of the slot +static inline int +CallSlotSet( + Tcl_Interp *interp, + Object *slot, + Tcl_Obj *list) +{ + Tcl_Obj *setArgs[] = { + slot->fPtr->myName, + slot->fPtr->slotSetName, + list + }; + return TclOOPrivateObjectCmd(slot, interp, 3, setArgs); +} + +// Call [$slot Resolve $item] to convert a slot item into canonical form +static inline Tcl_Obj * +CallSlotResolve( + Tcl_Interp *interp, + Object *slot, + Tcl_Obj *item) +{ + Tcl_Obj *resolveArgs[] = { + slot->fPtr->myName, + slot->fPtr->slotResolveName, + item + }; + int code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +static inline Tcl_Obj * +ResolveAll( + Tcl_Interp *interp, + Object *slot, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * objc); + for (int i = 0; i < objc; i++) { + resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]); + if (resolvedItems[i] == NULL) { + for (int j = 0; j < i; j++) { + Tcl_DecrRefCount(resolvedItems[j]); + } + TclStackFree(interp, (void *) resolvedItems); + return NULL; + } + Tcl_IncrRefCount(resolvedItems[i]); + Tcl_ResetResult(interp); + } + Tcl_Obj *resolvedList = Tcl_NewListObj(objc, resolvedItems); + for (int i = 0; i < objc; i++) { + TclDecrRefCount(resolvedItems[i]); + } + TclStackFree(interp, (void *) resolvedItems); + return resolvedList; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Append -- + * + * Implementation of the "-append" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Append( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + Tcl_Obj *list = CallSlotGet(interp, oPtr); + if (list == NULL) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_IncrRefCount(list); + Tcl_ResetResult(interp); + + // Append + if (Tcl_IsShared(list)) { + Tcl_Obj *dup = Tcl_DuplicateObj(list); + Tcl_IncrRefCount(dup); + Tcl_DecrRefCount(list); + list = dup; + } + if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_DecrRefCount(resolved); + + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_AppendNew -- + * + * Implementation of the "-appendifnew" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_AppendNew( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + Tcl_Obj *list = CallSlotGet(interp, oPtr); + if (list == NULL) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_IncrRefCount(list); + Tcl_ResetResult(interp); + + // Prepare a set of items in the list to set + Tcl_Size listc; + Tcl_Obj **listv; + if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_HashTable unique; + Tcl_InitObjHashTable(&unique); + for (Tcl_Size i=0 ; i<listc; i++) { + Tcl_CreateHashEntry(&unique, listv[i], NULL); + } + + // Append the new items if they're not already there + if (Tcl_IsShared(list)) { + Tcl_Obj *dup = Tcl_DuplicateObj(list); + Tcl_IncrRefCount(dup); + Tcl_DecrRefCount(list); + list = dup; + } + TclListObjGetElements(NULL, resolved, &listc, &listv); + for (Tcl_Size i=0 ; i<listc; i++) { + int isNew; + Tcl_CreateHashEntry(&unique, listv[i], &isNew); + if (isNew) { + Tcl_ListObjAppendElement(interp, list, listv[i]); + } + } + Tcl_DecrRefCount(resolved); + Tcl_DeleteHashTable(&unique); + + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Clear -- + * + * Implementation of the "-clear" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Clear( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip != objc) { + Tcl_WrongNumArgs(interp, skip, objv, NULL); + return TCL_ERROR; + } + Tcl_Obj *list = Tcl_NewObj(); + Tcl_IncrRefCount(list); + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Prepend -- + * + * Implementation of the "-prepend" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Prepend( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + Tcl_Obj *list = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (list == NULL) { + return TCL_ERROR; + } + Tcl_IncrRefCount(list); + + // Get slot contents and append to list + Tcl_Obj *oldList = CallSlotGet(interp, oPtr); + if (oldList == NULL) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + Tcl_ListObjAppendList(NULL, list, oldList); + Tcl_ResetResult(interp); + + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Remove -- + * + * Implementation of the "-remove" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Remove( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + Tcl_Obj *oldList = CallSlotGet(interp, oPtr); + if (oldList == NULL) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_IncrRefCount(oldList); + Tcl_ResetResult(interp); + + // Prepare a set of items in the list to remove + Tcl_Size listc; + Tcl_Obj **listv; + TclListObjGetElements(NULL, resolved, &listc, &listv); + Tcl_HashTable removeSet; + Tcl_InitObjHashTable(&removeSet); + for (Tcl_Size i=0 ; i<listc; i++) { + Tcl_CreateHashEntry(&removeSet, listv[i], NULL); + } + Tcl_DecrRefCount(resolved); + + // Append the new items from the old items if they're not in the remove set + if (TclListObjGetElements(interp, oldList, &listc, &listv) != TCL_OK) { + Tcl_DecrRefCount(oldList); + Tcl_DeleteHashTable(&removeSet); + return TCL_ERROR; + } + Tcl_Obj *newList = Tcl_NewObj(); + for (Tcl_Size i=0 ; i<listc; i++) { + if (Tcl_FindHashEntry(&removeSet, listv[i]) == NULL) { + Tcl_ListObjAppendElement(NULL, newList, listv[i]); + } + } + Tcl_DecrRefCount(oldList); + Tcl_DeleteHashTable(&removeSet); + + // Set slot contents + Tcl_IncrRefCount(newList); + int code = CallSlotSet(interp, oPtr, newList); + Tcl_DecrRefCount(newList); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Resolve -- + * + * Default implementation of the "Resolve" slot accessor. Just returns + * its argument unchanged; particular slots may override. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Resolve( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip + 1 != objc) { + Tcl_WrongNumArgs(interp, skip, objv, "list"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objv[objc - 1]); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Set -- + * + * Implementation of the "-set" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Set( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + Tcl_Obj *list; + + // Resolve all values + if (skip == objc) { + list = Tcl_NewObj(); + } else { + list = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (list == NULL) { + return TCL_ERROR; + } + } + Tcl_IncrRefCount(list); + + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Unimplemented -- + * + * Default implementation of the "Get" and "Set" slot accessors. Just + * returns an error; actual slots must override. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Unimplemented( + TCL_UNUSED(void *), + Tcl_Interp *interp, + TCL_UNUSED(Tcl_ObjectContext), + TCL_UNUSED(int), + TCL_UNUSED(Tcl_Obj *const *)) +{ + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + OO_ERROR(interp, ABSTRACT_SLOT); + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Unknown -- + * + * Unknown method name handler for slots. Delegates to the default slot + * operation (--default-operation forwarded method) unless the first + * argument starts with a dash. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Unknown( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context); + if (skip >= objc) { + Tcl_Obj *args[] = { + oPtr->fPtr->myName, + oPtr->fPtr->slotDefOpName + }; + return TclOOPrivateObjectCmd(oPtr, interp, 2, args); + } else if (TclGetString(objv[skip])[0] != '-') { + Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * (objc - skip + 2)); + args[0] = oPtr->fPtr->myName; + args[1] = oPtr->fPtr->slotDefOpName; + memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip)); + int code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args); + TclStackFree(interp, args); + return code; + } + return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip); +} + +/* + * ---------------------------------------------------------------------- + * * ClassFilter_Get, ClassFilter_Set -- * * Implementation of the "filter" slot accessors of the "oo::define" |