diff options
-rw-r--r-- | generic/tclOO.c | 25 | ||||
-rw-r--r-- | generic/tclOOBasic.c | 3 | ||||
-rw-r--r-- | generic/tclOOCall.c | 156 | ||||
-rw-r--r-- | generic/tclOOInfo.c | 3 | ||||
-rw-r--r-- | generic/tclOOInt.h | 11 | ||||
-rw-r--r-- | tests/oo.test | 110 |
6 files changed, 253 insertions, 55 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c index 1080967..6aa03fa 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1174,7 +1174,7 @@ ObjectNamespaceDeleted( if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); int result; Tcl_InterpState state; @@ -1651,7 +1651,7 @@ Tcl_NewObjectInstance( if (objc >= 0) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr != NULL) { int isRoot, result; @@ -1724,7 +1724,7 @@ TclNRNewObjectInstance( *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; @@ -2164,7 +2164,8 @@ Tcl_CopyObjectInstance( } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, + NULL, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); args[1] = oPtr->fPtr->clonedName; @@ -2562,6 +2563,8 @@ TclOOObjectCmdCore( CallContext *contextPtr; Tcl_Obj *methodNamePtr; CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + Object *callerObjPtr = NULL; + Class *callerClsPtr = NULL; int result; /* @@ -2585,11 +2588,11 @@ TclOOObjectCmdCore( Method *callerMethodPtr = callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; - if (callerMethodPtr->declaringObjectPtr == oPtr) { - flags |= OBJECT_PRIVATE_METHOD; + if (callerMethodPtr->declaringObjectPtr) { + callerObjPtr = callerMethodPtr->declaringObjectPtr; } - if (callerMethodPtr->declaringClassPtr == oPtr->selfCls) { - flags |= CLASS_PRIVATE_METHOD; + if (callerMethodPtr->declaringClassPtr) { + callerClsPtr = callerMethodPtr->declaringClassPtr; } } @@ -2620,7 +2623,8 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2637,7 +2641,8 @@ TclOOObjectCmdCore( noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), NULL); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index d874cba..dc49356 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -347,7 +347,8 @@ TclOO_Object_Destroy( } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, + NULL); if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index aa30808..55f7e5b 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -60,6 +60,13 @@ static inline void AddMethodToCallChain(Method *const mPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); static inline void AddSimpleChainToCallContext(Object *const oPtr, + Object *const contextObj, Class *const contextCls, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static void AddPrivatesFromClassChainToCallContext(Class *classPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, @@ -703,6 +710,12 @@ AddClassMethodNames( static inline void AddSimpleChainToCallContext( Object *const oPtr, /* Object to add call chain entries for. */ + Object *const contextObj, /* Context object; when equal to oPtr, it + * means that private methods may also be + * added. [TIP 500] */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ @@ -720,7 +733,7 @@ AddSimpleChainToCallContext( Tcl_HashEntry *hPtr; Method *mPtr; - if (flags & OBJECT_PRIVATE_METHOD && oPtr->methodsPtr) { + if ((oPtr == contextObj) && oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { @@ -730,7 +743,6 @@ AddSimpleChainToCallContext( flags); } } - flags &= ~OBJECT_PRIVATE_METHOD; flags |= DEFINITE_PROTECTED; } else if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); @@ -752,6 +764,11 @@ AddSimpleChainToCallContext( Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { + if (contextCls) { + AddPrivatesFromClassChainToCallContext(mixinPtr, contextCls, + methodNameObj, cbPtr, doneFilters, + flags|TRAVERSED_MIXIN, filterDecl); + } AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, filterDecl); } @@ -766,6 +783,10 @@ AddSimpleChainToCallContext( } } } + if (contextCls) { + AddPrivatesFromClassChainToCallContext(oPtr->selfCls, contextCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } @@ -971,6 +992,12 @@ TclOOGetCallContext( * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ + Object *contextObj, /* Context object; when equal to oPtr, it + * means that private methods may also be + * added. [TIP 500] */ + Class *contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is * to be in the same object as the * methodNameObj. */ @@ -1070,10 +1097,11 @@ TclOOGetCallContext( */ if (flags & FORCE_UNKNOWN) { - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (callPtr->numChain == 0) { @@ -1102,10 +1130,10 @@ TclOOGetCallContext( OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, - BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, - NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, + filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, + filterObj, &cb, &doneFilters, 0, NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, BUILDING_MIXINS); @@ -1120,9 +1148,10 @@ TclOOGetCallContext( * handle class mixins right. */ - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, - flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj, + &cb, NULL, flags|BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(oPtr, contextObj, contextCls, methodNameObj, + &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1140,10 +1169,11 @@ TclOOGetCallContext( TclOODeleteChain(callPtr); return NULL; } - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1301,9 +1331,10 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, + AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(&obj, NULL, NULL, methodNameObj, &cb, NULL, + flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1312,10 +1343,10 @@ TclOOGetStereotypeCallChain( */ if (count == callPtr->numChain) { - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, 0, NULL); + AddSimpleChainToCallContext(&obj, NULL, NULL, + fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, NULL, + fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1395,9 +1426,9 @@ AddClassFiltersToCallContext( (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, NULL, filterObj, cbPtr, doneFilters, clearedFlags, clsPtr); } } @@ -1432,8 +1463,11 @@ AddClassFiltersToCallContext( */ static void -AddSimpleClassChainToCallContext( +AddPrivatesFromClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ @@ -1447,10 +1481,70 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i, private = (flags & CLASS_PRIVATE_METHOD); + int i; Class *superPtr; - flags &= ~CLASS_PRIVATE_METHOD; + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + * + * Note that mixins must be processed before the main class hierarchy. + * [Bug 1998221] + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodNameObj, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, + filterDecl); + } + + if (classPtr == contextCls) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, + (char *) methodNameObj); + + if (hPtr != NULL) { + register Method *mPtr = Tcl_GetHashValue(hPtr); + + if (mPtr->flags & TRUE_PRIVATE_METHOD) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } + } + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } + case 0: + return; + } +} + +static void +AddSimpleClassChainToCallContext( + Class *classPtr, /* Class to add the call chain entries for. */ + Tcl_Obj *const methodNameObj, + /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + Tcl_HashTable *const doneFilters, + /* Where to record what call chain entries + * have been processed. */ + int flags, /* What sort of call chain are we building. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + int i; + Class *superPtr; /* * We hard-code the tail-recursive form. It's by far the most common case @@ -1480,9 +1574,7 @@ AddSimpleClassChainToCallContext( if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (private && mPtr->flags & TRUE_PRIVATE_METHOD) { - flags |= DEFINITE_PROTECTED; - } else if (!(flags & KNOWN_STATE)) { + if (!(flags & KNOWN_STATE)) { if (flags & PUBLIC_METHOD) { if (mPtr->flags & PUBLIC_METHOD) { flags |= DEFINITE_PUBLIC; @@ -1493,7 +1585,7 @@ AddSimpleClassChainToCallContext( flags |= DEFINITE_PROTECTED; } } - if (private || !(mPtr->flags & TRUE_PRIVATE_METHOD)) { + if (!(mPtr->flags & TRUE_PRIVATE_METHOD)) { AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index d189528..30cf8af 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -1597,7 +1597,8 @@ InfoObjectCallCmd( * Get the call context and render its call chain. */ - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, + NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot construct any call chain", -1)); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 55847ca..1937680 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -403,16 +403,6 @@ typedef struct CallContext { /* This is a private method only accessible * from other methods defined on this class * or instance. [TIP #500] */ -#define OBJECT_PRIVATE_METHOD 0x40 - /* This is a call of a method on an object - * that may include TRUE_PRIVATE_METHOD - * instance method implementations in its call - * chain. */ -#define CLASS_PRIVATE_METHOD 0x80 - /* This is a call of a method on an object - * that may include TRUE_PRIVATE_METHOD class - * method implementations in its call - * chain. */ /* * Structure containing definition information about basic class methods. @@ -546,6 +536,7 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, + Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); diff --git a/tests/oo.test b/tests/oo.test index 491ac20..1075d0d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4217,7 +4217,6 @@ test oo-37.6 {TIP 500: private command can't be used outside definitions} -body oo::objdefine::private error "xyz" } -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} - test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { oo::class create parent } -body { @@ -4299,6 +4298,115 @@ test oo-38.2 {TIP 500: private variables introspection} -setup { } -cleanup { parent destroy } -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} + +test oo-38.1 {TIP 500: private methods internal call} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + clsA create obj + obj act + list [obj x] [catch {obj step} msg] $msg +} -cleanup { + parent destroy +} -result {7 1 {unknown method "step": must be act, destroy or x}} +test oo-38.2 {TIP 500: private methods internal call} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method step {} { + incr x 5 + } + } + clsB create obj + obj act + list [obj x] [obj step] +} -cleanup { + parent destroy +} -result {7 12} +test oo-38.3 {TIP 500: private methods internal call} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my Step + my Step + my Step + return + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method Step {} { + incr x 5 + } + } + clsB create obj + obj act + set result [obj x] + oo::define clsA { + private { + method Step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {16 22} cleanupTests return |