diff options
Diffstat (limited to 'generic/tclOOCall.c')
-rw-r--r-- | generic/tclOOCall.c | 1211 |
1 files changed, 994 insertions, 217 deletions
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index bfff4e9..23db75c 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -2,9 +2,10 @@ * tclOOCall.c -- * * This file contains the method call chain management code for the - * object-system core. + * object-system core. It also contains everything else that does + * inheritance hierarchy traversal. * - * Copyright (c) 2005-2012 Donal K. Fellows + * Copyright © 2005-2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,6 +16,7 @@ #endif #include "tclInt.h" #include "tclOOInt.h" +#include <assert.h> /* * Structure containing a CallContext and any other values needed only during @@ -31,6 +33,22 @@ struct ChainBuilder { }; /* + * Structures used for traversing the class hierarchy to find out where + * definitions are supposed to be done. + */ + +typedef struct { + Class *definerCls; + Tcl_Obj *namespaceName; +} DefineEntry; + +typedef struct { + DefineEntry *list; + int num; + int size; +} DefineChain; + +/* * Extra flags used for call chain management. */ @@ -41,11 +59,34 @@ struct ChainBuilder { #define BUILDING_MIXINS 0x400000 #define TRAVERSED_MIXIN 0x800000 #define OBJECT_MIXIN 0x1000000 +#define DEFINE_FOR_CLASS 0x2000000 #define MIXIN_CONSISTENT(flags) \ (((flags) & OBJECT_MIXIN) || \ !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) /* + * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for + * Itcl's special type of private. + */ + +#define IS_PUBLIC(mPtr) \ + (((mPtr)->flags & PUBLIC_METHOD) != 0) +#define IS_UNEXPORTED(mPtr) \ + (((mPtr)->flags & SCOPE_FLAGS) == 0) +#define IS_ITCLPRIVATE(mPtr) \ + (((mPtr)->flags & PRIVATE_METHOD) != 0) +#define IS_PRIVATE(mPtr) \ + (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) +#define WANT_PUBLIC(flags) \ + (((flags) & PUBLIC_METHOD) != 0) +#define WANT_UNEXPORTED(flags) \ + (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0) +#define WANT_ITCLPRIVATE(flags) \ + (((flags) & PRIVATE_METHOD) != 0) +#define WANT_PRIVATE(flags) \ + (((flags) & TRUE_PRIVATE_METHOD) != 0) + +/* * Function declarations for things defined in this file. */ @@ -55,20 +96,41 @@ static void AddClassFiltersToCallContext(Object *const oPtr, static void AddClassMethodNames(Class *clsPtr, int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); +static inline void AddDefinitionNamespaceToChain(Class *const definerCls, + Tcl_Obj *const namespaceName, + DefineChain *const definePtr, int flags); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); -static inline void AddSimpleChainToCallContext(Object *const oPtr, +static inline int AddInstancePrivateToCallContext(Object *const oPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, int flags); +static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr, + Method *mPtr, Tcl_HashTable *namesPtr); +static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr); +static inline int AddSimpleChainToCallContext(Object *const oPtr, + Class *const contextCls, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static int AddPrivatesFromClassChainToCallContext(Class *classPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); -static void AddSimpleClassChainToCallContext(Class *classPtr, +static int AddSimpleClassChainToCallContext(Class *classPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); +static void AddSimpleClassDefineNamespaces(Class *classPtr, + DefineChain *const definePtr, int flags); +static inline void AddSimpleDefineNamespaces(Object *const oPtr, + DefineChain *const definePtr, int flags); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; @@ -77,6 +139,8 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; +static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, + const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* @@ -185,11 +249,12 @@ StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { + Tcl_ObjInternalRep ir; + callPtr->refCount++; TclGetString(objPtr); - TclFreeIntRep(objPtr); - objPtr->typePtr = &methodNameType; - objPtr->internalRep.twoPtrValue.ptr1 = callPtr; + ir.twoPtrValue.ptr1 = callPtr; + Tcl_StoreInternalRep(objPtr, &methodNameType, &ir); } void @@ -216,21 +281,16 @@ DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; - - dstPtr->typePtr = &methodNameType; - dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; - callPtr->refCount++; + StashCallChain(dstPtr, + (CallChain *)TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); } static void FreeMethodNameRep( Tcl_Obj *objPtr) { - CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; - - TclOODeleteChain(callPtr); - objPtr->typePtr = NULL; + TclOODeleteChain( + (CallChain *)TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1); } /* @@ -311,14 +371,14 @@ TclOOInvokeContext( * Run the method implementation. */ - return mPtr->typePtr->callProc(mPtr->clientData, interp, + return (mPtr->typePtr->callProc)(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, objc, objv); } static int SetFilterFlags( void *data[], - Tcl_Interp *interp, + TCL_UNUSED(Tcl_Interp *), int result) { CallContext *contextPtr = (CallContext *)data[0]; @@ -330,7 +390,7 @@ SetFilterFlags( static int ResetFilterFlags( void *data[], - Tcl_Interp *interp, + TCL_UNUSED(Tcl_Interp *), int result) { CallContext *contextPtr = (CallContext *)data[0]; @@ -342,7 +402,7 @@ ResetFilterFlags( static int FinalizeMethodRefs( void *data[], - Tcl_Interp *interp, + TCL_UNUSED(Tcl_Interp *), int result) { CallContext *contextPtr = (CallContext *)data[0]; @@ -367,6 +427,14 @@ FinalizeMethodRefs( int TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ + Object *contextObj, /* From what context object we are inquiring. + * NULL when the context shouldn't see + * object-level private methods. Note that + * flags can override this. */ + Class *contextCls, /* From what context class we are inquiring. + * NULL when the context shouldn't see + * class-level private methods. Note that + * flags can override this. */ int flags, /* Whether we just want the public method * names. */ const char ***stringsPtr) /* Where to write a pointer to the array of @@ -379,12 +447,10 @@ TclOOGetSortedMethodList( * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - int i; + int i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; - int isWantedIn; - void *isWanted; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -401,18 +467,13 @@ TclOOGetSortedMethodList( if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - int isNew; - - if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { + if (IS_PRIVATE(mPtr)) { continue; } - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = ((!(flags & PUBLIC_METHOD) - || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); - isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); + if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) { + continue; } + AddStandardMethodName(flags, namePtr, mPtr, &names); } } @@ -420,84 +481,46 @@ TclOOGetSortedMethodList( * Process method names due to private methods on the object's class. */ - if (flags & PRIVATE_METHOD) { + if (WANT_UNEXPORTED(flags)) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if (mPtr->flags & PRIVATE_METHOD) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = IN_LIST; - if (mPtr->typePtr == NULL) { - isWantedIn |= NO_IMPLEMENTATION; - } - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } else if (mPtr->typePtr != NULL) { - isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); - if (isWantedIn & NO_IMPLEMENTATION) { - isWantedIn &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } - } + if (IS_UNEXPORTED(mPtr)) { + AddStandardMethodName(flags, namePtr, mPtr, &names); } } } /* + * Process method names due to private methods on the context's object or + * class. Which must be correct if either are not NULL. + */ + + if (contextObj && contextObj->methodsPtr) { + AddPrivateMethodNames(contextObj->methodsPtr, &names); + } + if (contextCls) { + AddPrivateMethodNames(&contextCls->classMethods, &names); + } + + /* * Process (normal) method names from the class hierarchy and the mixin * hierarchy. */ AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names, + AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names, &examinedClasses); } - Tcl_DeleteHashTable(&examinedClasses); - /* - * See how many (visible) method names there are. If none, we do not (and - * should not) try to sort the list of them. + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). */ - i = 0; - if (names.numEntries != 0) { - const char **strings; - - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ - - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); - } - } - - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ - - if (i > 0) { - if (i > 1) { - qsort((void *) strings, i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); - } - } - + Tcl_DeleteHashTable(&examinedClasses); + numStrings = SortMethodNames(&names, flags, stringsPtr); Tcl_DeleteHashTable(&names); - return i; + return numStrings; } int @@ -514,10 +537,7 @@ TclOOGetSortedClassMethodList( /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - FOREACH_HASH_DECLS; - int i; - Tcl_Obj *namePtr; - void *isWanted; + int numStrings; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -530,51 +550,101 @@ TclOOGetSortedClassMethodList( Tcl_DeleteHashTable(&examinedClasses); /* + * Process private method names if we should. [TIP 500] + */ + + if (WANT_PRIVATE(flags)) { + AddPrivateMethodNames(&clsPtr->classMethods, &names); + flags &= ~TRUE_PRIVATE_METHOD; + } + + /* + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). + */ + + numStrings = SortMethodNames(&names, flags, stringsPtr); + Tcl_DeleteHashTable(&names); + return numStrings; +} + +/* + * ---------------------------------------------------------------------- + * + * SortMethodNames -- + * + * Shared helper for TclOOGetSortedMethodList etc. that knows the method + * sorting rules. + * + * Returns: + * The length of the sorted list. + * + * ---------------------------------------------------------------------- + */ + +static int +SortMethodNames( + Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains + * whether the names are wanted and under what + * circumstances. */ + int flags, /* Whether we are looking for unexported + * methods. Full private methods are handled + * on insertion to the table. */ + const char ***stringsPtr) /* Where to store the sorted list of strings + * that we produce. ckalloced() */ +{ + const char **strings; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + void *isWanted; + int i = 0; + + /* * See how many (visible) method names there are. If none, we do not (and * should not) try to sort the list of them. */ - i = 0; - if (names.numEntries != 0) { - const char **strings; + if (namesPtr->numEntries == 0) { + *stringsPtr = NULL; + return 0; + } - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ + /* + * We need to build the list of methods to sort. We will be using qsort() + * for this, because it is very unlikely that the list will be heavily + * sorted when it is long enough to matter. + */ - strings = (const char **)ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); + strings = (const char **)ckalloc(sizeof(char *) * namesPtr->numEntries); + FOREACH_HASH(namePtr, isWanted, namesPtr) { + if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { + if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { + continue; } + strings[i++] = TclGetString(namePtr); } + } - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. We don't sort unless there's at least + * two method names. + */ - if (i > 0) { - if (i > 1) { - qsort((void *) strings, i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); + if (i > 0) { + if (i > 1) { + qsort((void *) strings, i, sizeof(char *), CmpStr); } + *stringsPtr = strings; + } else { + ckfree(strings); + *stringsPtr = NULL; } - - Tcl_DeleteHashTable(&names); return i; } /* - * Comparator for GetSortedMethodList + * Comparator for SortMethodNames */ static int @@ -585,7 +655,7 @@ CmpStr( const char **strPtr1 = (const char **) ptr1; const char **strPtr2 = (const char **) ptr2; - return TclUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1); + return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1); } /* @@ -618,6 +688,8 @@ AddClassMethodNames( * pointers to the classes, and the values are * immaterial. */ { + int i; + /* * If we've already started looking at this class, stop working on it now * to prevent repeated work. @@ -648,7 +720,6 @@ AddClassMethodNames( if (clsPtr->mixins.num != 0) { Class *mixinPtr; - int i; FOREACH(mixinPtr, clsPtr->mixins) { if (mixinPtr != clsPtr) { @@ -659,20 +730,7 @@ AddClassMethodNames( } FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - if (isNew) { - int isWanted = (!(flags & PUBLIC_METHOD) - || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0; - - isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) - && mPtr->typePtr != NULL) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); - - isWanted &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } + AddStandardMethodName(flags, namePtr, mPtr, namesPtr); } if (clsPtr->superclasses.num != 1) { @@ -682,7 +740,6 @@ AddClassMethodNames( } if (clsPtr->superclasses.num != 0) { Class *superPtr; - int i; FOREACH(superPtr, clsPtr->superclasses) { AddClassMethodNames(superPtr, flags, namesPtr, @@ -694,19 +751,121 @@ AddClassMethodNames( /* * ---------------------------------------------------------------------- * + * AddPrivateMethodNames, AddStandardMethodName -- + * + * Factored-out helpers for the sorted name list production functions. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddPrivateMethodNames( + Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr) +{ + FOREACH_HASH_DECLS; + Method *mPtr; + Tcl_Obj *namePtr; + + FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { + if (IS_PRIVATE(mPtr)) { + int isNew; + + hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); + } + } +} + +static inline void +AddStandardMethodName( + int flags, + Tcl_Obj *namePtr, + Method *mPtr, + Tcl_HashTable *namesPtr) +{ + if (!IS_PRIVATE(mPtr)) { + int isNew; + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + + if (isNew) { + int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) + ? IN_LIST : 0; + + isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) + && mPtr->typePtr != NULL) { + int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + + isWanted &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } + } +} + +#undef IN_LIST +#undef NO_IMPLEMENTATION + +/* + * ---------------------------------------------------------------------- + * + * AddInstancePrivateToCallContext -- + * + * Add private methods from the instance. Called when the calling Tcl + * context is a TclOO method declared by an object that is the same as + * the current object. Returns true iff a private method was actually + * found and added to the call chain (as this suppresses caching). + * + * ---------------------------------------------------------------------- + */ + +static inline int +AddInstancePrivateToCallContext( + Object *const oPtr, /* Object to add call chain entries for. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + int flags) /* What sort of call chain are we building. */ +{ + Tcl_HashEntry *hPtr; + Method *mPtr; + int donePrivate = 0; + + if (oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); + if (hPtr != NULL) { + mPtr = (Method *)Tcl_GetHashValue(hPtr); + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); + donePrivate = 1; + } + } + } + return donePrivate; +} + +/* + * ---------------------------------------------------------------------- + * * AddSimpleChainToCallContext -- * * The core of the call-chain construction engine, this handles calling a * particular method on a particular object. Note that filters and * unknown handling are already handled by the logic that uses this - * function. + * function. Returns true if a private method was one of those found. * * ---------------------------------------------------------------------- */ -static inline void +static inline int AddSimpleChainToCallContext( Object *const oPtr, /* Object to add 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. */ @@ -720,44 +879,62 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, foundPrivate = 0, blockedUnexported = 0; + Tcl_HashEntry *hPtr; + Method *mPtr; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, - (char *) methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { - Method *mPtr = (Method *)Tcl_GetHashValue(hPtr); - - if (flags & PUBLIC_METHOD) { - if (!(mPtr->flags & PUBLIC_METHOD)) { - return; + mPtr = (Method *)Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + if (WANT_PUBLIC(flags)) { + if (!IS_PUBLIC(mPtr)) { + blockedUnexported = 1; + } else { + flags |= DEFINITE_PUBLIC; + } } else { - flags |= DEFINITE_PUBLIC; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } } } if (!(flags & SPECIAL)) { - Tcl_HashEntry *hPtr; Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext( + mixinPtr, contextCls, methodNameObj, cbPtr, + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + } + foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr, + methodNameObj, cbPtr, doneFilters, + flags | TRAVERSED_MIXIN, filterDecl); } - if (oPtr->methodsPtr) { + if (oPtr->methodsPtr && !blockedUnexported) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { - AddMethodToCallChain((Method *)Tcl_GetHashValue(hPtr), cbPtr, - doneFilters, filterDecl, flags); + mPtr = (Method *)Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } } } } - AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls, + contextCls, methodNameObj, cbPtr, doneFilters, flags, + filterDecl); + } + if (!blockedUnexported) { + foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } + return foundPrivate; } /* @@ -820,8 +997,8 @@ AddMethodToCallChain( * should be sufficient for [incr Tcl] support though. */ - if (!(callPtr->flags & PRIVATE_METHOD) - && (mPtr->flags & PRIVATE_METHOD) + if (!WANT_UNEXPORTED(callPtr->flags) + && IS_UNEXPORTED(mPtr) && (mPtr->declaringClassPtr != NULL) && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { return; @@ -981,6 +1158,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. */ @@ -989,7 +1172,7 @@ TclOOGetCallContext( CallChain *callPtr; struct ChainBuilder cb; int i, count; - int doFilters; + int doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1029,15 +1212,16 @@ TclOOGetCallContext( * the object, and in the class). */ - const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const Tcl_ObjInternalRep *irPtr; + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); - if (cacheInThisObj->typePtr == &methodNameType) { - callPtr = (CallChain *)cacheInThisObj->internalRep.twoPtrValue.ptr1; + if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) { + callPtr = (CallChain *)irPtr->twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - FreeMethodNameRep(cacheInThisObj); + Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL); } /* @@ -1089,10 +1273,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, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (callPtr->numChain == 0) { @@ -1121,10 +1306,10 @@ TclOOGetCallContext( OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, - BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, - NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, 0, NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, BUILDING_MIXINS); @@ -1139,9 +1324,15 @@ TclOOGetCallContext( * handle class mixins right. */ - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, - flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + if (oPtr == contextObj) { + donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, + &cb, flags); + donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS); + } + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1159,17 +1350,18 @@ 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, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } - } else if (doFilters) { + } else if (doFilters && !donePrivate) { if (hPtr == NULL) { if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { @@ -1286,8 +1478,7 @@ TclOOGetStereotypeCallChain( hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { - const int reuseMask = - ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); callPtr = (CallChain *)Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, &obj, flags, reuseMask)) { @@ -1331,9 +1522,10 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags, + NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1342,10 +1534,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, fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1426,9 +1618,9 @@ AddClassFiltersToCallContext( (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags, clsPtr); } } @@ -1455,18 +1647,22 @@ AddClassFiltersToCallContext( /* * ---------------------------------------------------------------------- * - * AddSimpleClassChainToCallContext -- + * AddPrivatesFromClassChainToCallContext -- * - * Construct a call-chain from a class hierarchy. + * Helper for AddSimpleChainToCallContext that is used to find private + * methds and add them to the call chain. Returns true when a private + * method is found and added. [TIP 500] * * ---------------------------------------------------------------------- */ -static void -AddSimpleClassChainToCallContext( +static int +AddPrivatesFromClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ - Tcl_Obj *const methodNameObj, - /* Name of method to add the call chain + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain * entries for. */ struct ChainBuilder *const cbPtr, /* Where to add the call chain entries. */ @@ -1498,8 +1694,87 @@ AddSimpleClassChainToCallContext( return; } FOREACH(superPtr, classPtr->mixins) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, + filterDecl)) { + return 1; + } + } + + if (classPtr == contextCls) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, + methodName); + + if (hPtr != NULL) { + Method *mPtr = (Method *)Tcl_GetHashValue(hPtr); + + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + return 1; + } + } + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags, filterDecl)) { + return 1; + } + } + /* FALLTHRU */ + case 0: + return 0; + } +} + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleClassChainToCallContext -- + * + * Construct a call-chain from a class hierarchy. + * + * ---------------------------------------------------------------------- + */ + +static int +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, privateDanger = 0; + Class *superPtr; + + /* + * 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) { + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, + filterDecl); } if (flags & CONSTRUCTOR) { @@ -1512,21 +1787,26 @@ AddSimpleClassChainToCallContext( Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); + if (classPtr->flags & HAS_PRIVATE_METHODS) { + privateDanger |= 1; + } if (hPtr != NULL) { Method *mPtr = (Method *)Tcl_GetHashValue(hPtr); - if (!(flags & KNOWN_STATE)) { - if (flags & PUBLIC_METHOD) { - if (mPtr->flags & PUBLIC_METHOD) { + if (!IS_PRIVATE(mPtr)) { + if (!(flags & KNOWN_STATE)) { + if (flags & PUBLIC_METHOD) { + if (!IS_PUBLIC(mPtr)) { + return privateDanger; + } flags |= DEFINITE_PUBLIC; } else { - return; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } } @@ -1536,12 +1816,12 @@ AddSimpleClassChainToCallContext( goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); } /* FALLTHRU */ case 0: - return; + return privateDanger; } } @@ -1561,7 +1841,7 @@ TclOORenderCallChain( Tcl_Interp *interp, CallChain *callPtr) { - Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); int i; @@ -1570,12 +1850,14 @@ TclOORenderCallChain( * Allocate the literals (potentially) used in our description. */ - filterLiteral = Tcl_NewStringObj("filter", -1); + TclNewLiteralStringObj(filterLiteral, "filter"); Tcl_IncrRefCount(filterLiteral); - methodLiteral = Tcl_NewStringObj("method", -1); + TclNewLiteralStringObj(methodLiteral, "method"); Tcl_IncrRefCount(methodLiteral); - objectLiteral = Tcl_NewStringObj("object", -1); + TclNewLiteralStringObj(objectLiteral, "object"); Tcl_IncrRefCount(objectLiteral); + TclNewLiteralStringObj(privateLiteral, "private"); + Tcl_IncrRefCount(privateLiteral); /* * Do the actual construction of the descriptions. They consist of a list @@ -1596,6 +1878,7 @@ TclOORenderCallChain( descObjs[0] = miPtr->isFilter ? filterLiteral : callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj : + IS_PRIVATE(miPtr->mPtr) ? privateLiteral : methodLiteral; descObjs[1] = callPtr->flags & CONSTRUCTOR ? fPtr->constructorName : @@ -1618,6 +1901,7 @@ TclOORenderCallChain( Tcl_DecrRefCount(filterLiteral); Tcl_DecrRefCount(methodLiteral); Tcl_DecrRefCount(objectLiteral); + Tcl_DecrRefCount(privateLiteral); /* * Finish building the description and return it. @@ -1629,6 +1913,499 @@ TclOORenderCallChain( } /* + * ---------------------------------------------------------------------- + * + * TclOOGetDefineContextNamespace -- + * + * Responsible for determining which namespace to use for definitions. + * This is done by building a define chain, which models (strongly!) the + * way that a call chain works but with a different internal model. + * + * Then it walks the chain to find the first namespace name that actually + * resolves to an existing namespace. + * + * Returns: + * Name of namespace, or NULL if none can be found. Note that this + * function does *not* set an error message in the interpreter on failure. + * + * ---------------------------------------------------------------------- + */ + +#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */ + +Tcl_Namespace * +TclOOGetDefineContextNamespace( + Tcl_Interp *interp, /* In what interpreter should namespace names + * actually be resolved. */ + Object *oPtr, /* The object to get the context for. */ + int forClass) /* What sort of context are we looking for. + * If true, we are going to use this for + * [oo::define], otherwise, we are going to + * use this for [oo::objdefine]. */ +{ + DefineChain define; + DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; + DefineEntry *entryPtr; + Tcl_Namespace *nsPtr = NULL; + int i, flags = (forClass ? DEFINE_FOR_CLASS : 0); + + define.list = staticSpace; + define.num = 0; + define.size = DEFINE_CHAIN_STATIC_SIZE; + + /* + * Add the actual define locations. We have to do this twice to handle + * class mixins right. + */ + + AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS); + AddSimpleDefineNamespaces(oPtr, &define, flags); + + /* + * Go through the list until we find a namespace whose name we can + * resolve. + */ + + FOREACH_STRUCT(entryPtr, define) { + if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName, + &nsPtr) == TCL_OK) { + break; + } + Tcl_ResetResult(interp); + } + if (define.list != staticSpace) { + ckfree(define.list); + } + return nsPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleDefineNamespaces -- + * + * Adds to the definition chain all the definitions provided by an + * object's class and its mixins, taking into account everything they + * inherit from. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddSimpleDefineNamespaces( + Object *const oPtr, /* Object to add define chain entries for. */ + DefineChain *const definePtr, + /* Where to add the define chain entries. */ + int flags) /* What sort of define chain are we + * building. */ +{ + Class *mixinPtr; + int i; + + FOREACH(mixinPtr, oPtr->mixins) { + AddSimpleClassDefineNamespaces(mixinPtr, definePtr, + flags | TRAVERSED_MIXIN); + } + + AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags); +} + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleClassDefineNamespaces -- + * + * Adds to the definition chain all the definitions provided by a class + * and its superclasses and its class mixins. + * + * ---------------------------------------------------------------------- + */ + +static void +AddSimpleClassDefineNamespaces( + Class *classPtr, /* Class to add the define chain entries for. */ + DefineChain *const definePtr, + /* Where to add the define chain entries. */ + int flags) /* What sort of define chain are we + * building. */ +{ + int i; + Class *superPtr; + + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + AddSimpleClassDefineNamespaces(superPtr, definePtr, + flags | TRAVERSED_MIXIN); + } + + if (flags & DEFINE_FOR_CLASS) { + AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, + definePtr, flags); + } else { + AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs, + definePtr, flags); + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); + } + case 0: + return; + } +} + +/* + * ---------------------------------------------------------------------- + * + * AddDefinitionNamespaceToChain -- + * + * Adds a single item to the definition chain (if it is meaningful), + * reallocating the space for the chain if necessary. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddDefinitionNamespaceToChain( + Class *const definerCls, /* What class defines this entry. */ + Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a + * no-op). */ + DefineChain *const definePtr, + /* The define chain to add the method + * implementation to. */ + int flags) /* Used to check if we're mixin-consistent + * only. Mixin-consistent means that either + * we're looking to add things from a mixin + * and we have passed a mixin, or we're not + * looking to add things from a mixin and have + * not passed a mixin. */ +{ + int i; + + /* + * Return if this entry is blank. This is also where we enforce + * mixin-consistency. + */ + + if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) { + return; + } + + /* + * First test whether the method is already in the call chain. + */ + + for (i=0 ; i<definePtr->num ; i++) { + if (definePtr->list[i].definerCls == definerCls) { + /* + * Call chain semantics states that methods come as *late* in the + * call chain as possible. This is done by copying down the + * following methods. Note that this does not change the number of + * method invocations in the call chain; it just rearranges them. + * + * We skip changing anything if the place we found was already at + * the end of the list. + */ + + if (i < definePtr->num - 1) { + memmove(&definePtr->list[i], &definePtr->list[i + 1], + sizeof(DefineEntry) * (definePtr->num - i - 1)); + definePtr->list[i].definerCls = definerCls; + definePtr->list[i].namespaceName = namespaceName; + } + return; + } + } + + /* + * Need to really add the define. This is made a bit more complex by the + * fact that we are using some "static" space initially, and only start + * realloc-ing if the chain gets long. + */ + + if (definePtr->num == definePtr->size) { + definePtr->size *= 2; + if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) { + DefineEntry *staticList = definePtr->list; + + definePtr->list = + (DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size); + memcpy(definePtr->list, staticList, + sizeof(DefineEntry) * definePtr->num); + } else { + definePtr->list = (DefineEntry *)ckrealloc(definePtr->list, + sizeof(DefineEntry) * definePtr->size); + } + } + definePtr->list[i].definerCls = definerCls; + definePtr->list[i].namespaceName = namespaceName; + definePtr->num++; +} + +/* + * ---------------------------------------------------------------------- + * + * FindClassProps -- + * + * Discover the properties known to a class and its superclasses. + * The property names become the keys in the accumulator hash table + * (which is used as a set). + * + * ---------------------------------------------------------------------- + */ + +static void +FindClassProps( + Class *clsPtr, /* The object to inspect. Must exist. */ + int writable, /* Whether we're after the readable or writable + * property set. */ + Tcl_HashTable *accumulator) /* Where to gather the names. */ +{ + int i, dummy; + Tcl_Obj *propName; + Class *mixin, *sup; + + tailRecurse: + if (writable) { + FOREACH(propName, clsPtr->properties.writable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } else { + FOREACH(propName, clsPtr->properties.readable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } + if (clsPtr->thisPtr->flags & ROOT_OBJECT) { + /* + * We do *not* traverse upwards from the root! + */ + return; + } + FOREACH(mixin, clsPtr->mixins) { + FindClassProps(mixin, writable, accumulator); + } + if (clsPtr->superclasses.num == 1) { + clsPtr = clsPtr->superclasses.list[0]; + goto tailRecurse; + } + FOREACH(sup, clsPtr->superclasses) { + FindClassProps(sup, writable, accumulator); + } +} + +/* + * ---------------------------------------------------------------------- + * + * FindObjectProps -- + * + * Discover the properties known to an object and all its classes. + * The property names become the keys in the accumulator hash table + * (which is used as a set). + * + * ---------------------------------------------------------------------- + */ + +static void +FindObjectProps( + Object *oPtr, /* The object to inspect. Must exist. */ + int writable, /* Whether we're after the readable or writable + * property set. */ + Tcl_HashTable *accumulator) /* Where to gather the names. */ +{ + int i, dummy; + Tcl_Obj *propName; + Class *mixin; + + if (writable) { + FOREACH(propName, oPtr->properties.writable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } else { + FOREACH(propName, oPtr->properties.readable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } + FOREACH(mixin, oPtr->mixins) { + FindClassProps(mixin, writable, accumulator); + } + FindClassProps(oPtr->selfCls, writable, accumulator); +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOGetAllClassProperties -- + * + * Get the list of all properties known to a class, including to its + * superclasses. Manages a cache so this operation is usually cheap. + * The order of properties in the resulting list is undefined. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOOGetAllClassProperties( + Class *clsPtr, /* The class to inspect. Must exist. */ + int writable, /* Whether to get writable properties. If + * false, readable properties will be returned + * instead. */ + int *allocated) /* Address of variable to set to true if a + * Tcl_Obj was allocated and may be safely + * modified by the caller. */ +{ + Tcl_HashTable hashTable; + FOREACH_HASH_DECLS; + Tcl_Obj *propName, *result; + void *dummy; + + /* + * Look in the cache. + */ + + if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) { + if (writable) { + if (clsPtr->properties.allWritableCache) { + *allocated = 0; + return clsPtr->properties.allWritableCache; + } + } else { + if (clsPtr->properties.allReadableCache) { + *allocated = 0; + return clsPtr->properties.allReadableCache; + } + } + } + + /* + * Gather the information. Unsorted! (Caller will sort.) + */ + + *allocated = 1; + Tcl_InitObjHashTable(&hashTable); + FindClassProps(clsPtr, writable, &hashTable); + TclNewObj(result); + FOREACH_HASH(propName, dummy, &hashTable) { + Tcl_ListObjAppendElement(NULL, result, propName); + } + Tcl_DeleteHashTable(&hashTable); + + /* + * Cache the information. Also purges the cache. + */ + + if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) { + if (clsPtr->properties.allWritableCache) { + Tcl_DecrRefCount(clsPtr->properties.allWritableCache); + clsPtr->properties.allWritableCache = NULL; + } + if (clsPtr->properties.allReadableCache) { + Tcl_DecrRefCount(clsPtr->properties.allReadableCache); + clsPtr->properties.allReadableCache = NULL; + } + } + clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch; + if (writable) { + clsPtr->properties.allWritableCache = result; + } else { + clsPtr->properties.allReadableCache = result; + } + Tcl_IncrRefCount(result); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOGetAllObjectProperties -- + * + * Get the list of all properties known to a object, including to its + * classes. Manages a cache so this operation is usually cheap. + * The order of properties in the resulting list is undefined. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOOGetAllObjectProperties( + Object *oPtr, /* The object to inspect. Must exist. */ + int writable, /* Whether to get writable properties. If + * false, readable properties will be returned + * instead. */ + int *allocated) /* Address of variable to set to true if a + * Tcl_Obj was allocated and may be safely + * modified by the caller. */ +{ + Tcl_HashTable hashTable; + FOREACH_HASH_DECLS; + Tcl_Obj *propName, *result; + void *dummy; + + /* + * Look in the cache. + */ + + if (oPtr->properties.epoch == oPtr->fPtr->epoch) { + if (writable) { + if (oPtr->properties.allWritableCache) { + *allocated = 0; + return oPtr->properties.allWritableCache; + } + } else { + if (oPtr->properties.allReadableCache) { + *allocated = 0; + return oPtr->properties.allReadableCache; + } + } + } + + /* + * Gather the information. Unsorted! (Caller will sort.) + */ + + *allocated = 1; + Tcl_InitObjHashTable(&hashTable); + FindObjectProps(oPtr, writable, &hashTable); + TclNewObj(result); + FOREACH_HASH(propName, dummy, &hashTable) { + Tcl_ListObjAppendElement(NULL, result, propName); + } + Tcl_DeleteHashTable(&hashTable); + + /* + * Cache the information. + */ + + if (oPtr->properties.epoch != oPtr->fPtr->epoch) { + if (oPtr->properties.allWritableCache) { + Tcl_DecrRefCount(oPtr->properties.allWritableCache); + oPtr->properties.allWritableCache = NULL; + } + if (oPtr->properties.allReadableCache) { + Tcl_DecrRefCount(oPtr->properties.allReadableCache); + oPtr->properties.allReadableCache = NULL; + } + } + oPtr->properties.epoch = oPtr->fPtr->epoch; + if (writable) { + oPtr->properties.allWritableCache = result; + } else { + oPtr->properties.allReadableCache = result; + } + Tcl_IncrRefCount(result); + return result; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |