diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 3528 |
1 files changed, 0 insertions, 3528 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c deleted file mode 100644 index 32bd940..0000000 --- a/generic/tclOODefineCmds.c +++ /dev/null @@ -1,3528 +0,0 @@ -/* - * tclOODefineCmds.c -- - * - * This file contains the implementation of the ::oo::define command, - * part of the object-system core (NB: not Tcl_Obj, but ::oo). - * - * Copyright © 2006-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. - */ - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif -#include "tclInt.h" -#include "tclOOInt.h" - -/* - * The actual value used to mark private declaration frames. - */ - -#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE) - -/* - * The maximum length of fully-qualified object name to use in an errorinfo - * message. Longer than this will be curtailed. - */ - -#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30 - -/* - * Some things that make it easier to declare a slot. - */ - -struct DeclaredSlot { - const char *name; - const Tcl_MethodType getterType; - const Tcl_MethodType setterType; - const Tcl_MethodType resolverType; -}; - -#define SLOT(name,getter,setter,resolver) \ - {"::oo::" name, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ - getter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ - resolver, NULL, NULL}} - -/* - * A [string match] pattern used to determine if a method should be exported. - */ - -#define PUBLIC_PATTERN "[a-z]*" - -/* - * Forward declarations. - */ - -static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); -static inline void BumpInstanceEpoch(Object *oPtr); -static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, - Tcl_Namespace *const namespacePtr); -static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, - Tcl_Obj *savedNameObj, const char *typeOfSubject); -static inline int MagicDefinitionInvoke(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, int cmdIndex, - int objc, Tcl_Obj *const *objv); -static inline Class * GetClassInOuterContext(Tcl_Interp *interp, - Tcl_Obj *className, const char *errMsg); -static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp, - Tcl_Obj *namespaceName); -static inline int InitDefineContext(Tcl_Interp *interp, - Tcl_Namespace *namespacePtr, Object *oPtr, - int objc, Tcl_Obj *const objv[]); -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 Tcl_MethodCallProc ClassFilterGet, ClassFilterSet; -static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet; -static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet; -static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet; -static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet; -static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet; -static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet; -static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet; -static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet; -static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet; -static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet; -static Tcl_MethodCallProc ResolveClass; - -/* - * Now define the slots used in declarations. - */ - -static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), - SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), - SLOT("configuresupport::readableproperties", - ClassRPropsGet, ClassRPropsSet, NULL), - SLOT("configuresupport::writableproperties", - ClassWPropsGet, ClassWPropsSet, NULL), - SLOT("configuresupport::objreadableproperties", - ObjRPropsGet, ObjRPropsSet, NULL), - SLOT("configuresupport::objwritableproperties", - ObjWPropsGet, ObjWPropsSet, NULL), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} -}; - -/* - * How to build the in-namespace name of a private variable. This is a pattern - * used with Tcl_ObjPrintf(). - */ - -#define PRIVATE_VARIABLE_PATTERN "%d : %s" - -/* - * ---------------------------------------------------------------------- - * - * IsPrivateDefine -- - * - * Extracts whether the current context is handling private definitions. - * - * ---------------------------------------------------------------------- - */ - -static inline int -IsPrivateDefine( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - if (!iPtr->varFramePtr) { - return 0; - } - return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME; -} - -/* - * ---------------------------------------------------------------------- - * - * BumpGlobalEpoch -- - * - * Utility that ensures that call chains that are invalid will get thrown - * away at an appropriate time. Note that exactly which epoch gets - * advanced will depend on exactly what the class is tangled up in; in - * the worst case, the simplest option is to advance the global epoch, - * causing *everything* to be thrown away on next usage. - * - * ---------------------------------------------------------------------- - */ - -static inline void -BumpGlobalEpoch( - Tcl_Interp *interp, - Class *classPtr) -{ - if (classPtr != NULL - && classPtr->subclasses.num == 0 - && classPtr->instances.num == 0 - && classPtr->mixinSubs.num == 0) { - /* - * If a class has no subclasses or instances, and is not mixed into - * anything, a change to its structure does not require us to - * invalidate any call chains. Note that we still bump our object's - * epoch if it has any mixins; the relation between a class and its - * representative object is special. But it won't hurt. - */ - - if (classPtr->thisPtr->mixins.num > 0) { - classPtr->thisPtr->epoch++; - - /* - * Invalidate the property caches directly. - */ - - if (classPtr->properties.allReadableCache) { - Tcl_DecrRefCount(classPtr->properties.allReadableCache); - classPtr->properties.allReadableCache = NULL; - } - if (classPtr->properties.allWritableCache) { - Tcl_DecrRefCount(classPtr->properties.allWritableCache); - classPtr->properties.allWritableCache = NULL; - } - } - return; - } - - /* - * Either there's no class (?!) or we're reconfiguring something that is - * in use. Force regeneration of call chains and properties. - */ - - TclOOGetFoundation(interp)->epoch++; -} - -/* - * ---------------------------------------------------------------------- - * - * BumpInstanceEpoch -- - * - * Advances the epoch and clears the property cache of an object. The - * equivalent for classes is BumpGlobalEpoch(), as classes have a more - * complex set of relationships to other entities. - * - * ---------------------------------------------------------------------- - */ - -static inline void -BumpInstanceEpoch( - Object *oPtr) -{ - oPtr->epoch++; - if (oPtr->properties.allReadableCache) { - Tcl_DecrRefCount(oPtr->properties.allReadableCache); - oPtr->properties.allReadableCache = NULL; - } - if (oPtr->properties.allWritableCache) { - Tcl_DecrRefCount(oPtr->properties.allWritableCache); - oPtr->properties.allWritableCache = NULL; - } -} - -/* - * ---------------------------------------------------------------------- - * - * RecomputeClassCacheFlag -- - * - * Determine whether the object is prototypical of its class, and hence - * able to use the class's method chain cache. - * - * ---------------------------------------------------------------------- - */ - -static inline void -RecomputeClassCacheFlag( - Object *oPtr) -{ - if ((oPtr->methodsPtr == NULL || oPtr->methodsPtr->numEntries == 0) - && (oPtr->mixins.num == 0) && (oPtr->filters.num == 0)) { - oPtr->flags |= USE_CLASS_CACHE; - } else { - oPtr->flags &= ~USE_CLASS_CACHE; - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjectSetFilters -- - * - * Install a list of filter method names into an object. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOObjectSetFilters( - Object *oPtr, - int numFilters, - Tcl_Obj *const *filters) -{ - int i; - - if (oPtr->filters.num) { - Tcl_Obj *filterObj; - - FOREACH(filterObj, oPtr->filters) { - Tcl_DecrRefCount(filterObj); - } - } - - if (numFilters == 0) { - /* - * No list of filters was supplied, so we're deleting filters. - */ - - ckfree(oPtr->filters.list); - oPtr->filters.list = NULL; - oPtr->filters.num = 0; - RecomputeClassCacheFlag(oPtr); - } else { - /* - * We've got a list of filters, so we're creating filters. - */ - - Tcl_Obj **filtersList; - int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ - - if (oPtr->filters.num == 0) { - filtersList = (Tcl_Obj **)ckalloc(size); - } else { - filtersList = (Tcl_Obj **)ckrealloc(oPtr->filters.list, size); - } - for (i = 0 ; i < numFilters ; i++) { - filtersList[i] = filters[i]; - Tcl_IncrRefCount(filters[i]); - } - oPtr->filters.list = filtersList; - oPtr->filters.num = numFilters; - oPtr->flags &= ~USE_CLASS_CACHE; - } - BumpInstanceEpoch(oPtr); /* Only this object can be affected. */ -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOClassSetFilters -- - * - * Install a list of filter method names into a class. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOClassSetFilters( - Tcl_Interp *interp, - Class *classPtr, - int numFilters, - Tcl_Obj *const *filters) -{ - int i; - - if (classPtr->filters.num) { - Tcl_Obj *filterObj; - - FOREACH(filterObj, classPtr->filters) { - Tcl_DecrRefCount(filterObj); - } - } - - if (numFilters == 0) { - /* - * No list of filters was supplied, so we're deleting filters. - */ - - ckfree(classPtr->filters.list); - classPtr->filters.list = NULL; - classPtr->filters.num = 0; - } else { - /* - * We've got a list of filters, so we're creating filters. - */ - - Tcl_Obj **filtersList; - int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ - - if (classPtr->filters.num == 0) { - filtersList = (Tcl_Obj **)ckalloc(size); - } else { - filtersList = (Tcl_Obj **)ckrealloc(classPtr->filters.list, size); - } - for (i = 0 ; i < numFilters ; i++) { - filtersList[i] = filters[i]; - Tcl_IncrRefCount(filters[i]); - } - classPtr->filters.list = filtersList; - classPtr->filters.num = numFilters; - } - - /* - * There may be many objects affected, so bump the global epoch. - */ - - BumpGlobalEpoch(interp, classPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjectSetMixins -- - * - * Install a list of mixin classes into an object. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOObjectSetMixins( - Object *oPtr, - int numMixins, - Class *const *mixins) -{ - Class *mixinPtr; - int i; - - if (numMixins == 0) { - if (oPtr->mixins.num != 0) { - FOREACH(mixinPtr, oPtr->mixins) { - TclOORemoveFromInstances(oPtr, mixinPtr); - TclOODecrRefCount(mixinPtr->thisPtr); - } - ckfree(oPtr->mixins.list); - oPtr->mixins.num = 0; - } - RecomputeClassCacheFlag(oPtr); - } else { - if (oPtr->mixins.num != 0) { - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr && mixinPtr != oPtr->selfCls) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } - TclOODecrRefCount(mixinPtr->thisPtr); - } - oPtr->mixins.list = (Class **)ckrealloc(oPtr->mixins.list, - sizeof(Class *) * numMixins); - } else { - oPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins); - oPtr->flags &= ~USE_CLASS_CACHE; - } - oPtr->mixins.num = numMixins; - memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins); - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr != oPtr->selfCls) { - TclOOAddToInstances(oPtr, mixinPtr); - - /* - * For the new copy created by memcpy(). - */ - - AddRef(mixinPtr->thisPtr); - } - } - } - BumpInstanceEpoch(oPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOClassSetMixins -- - * - * Install a list of mixin classes into a class. - * - * ---------------------------------------------------------------------- - */ - -void -TclOOClassSetMixins( - Tcl_Interp *interp, - Class *classPtr, - int numMixins, - Class *const *mixins) -{ - Class *mixinPtr; - int i; - - if (numMixins == 0) { - if (classPtr->mixins.num != 0) { - FOREACH(mixinPtr, classPtr->mixins) { - TclOORemoveFromMixinSubs(classPtr, mixinPtr); - TclOODecrRefCount(mixinPtr->thisPtr); - } - ckfree(classPtr->mixins.list); - classPtr->mixins.num = 0; - } - } else { - if (classPtr->mixins.num != 0) { - FOREACH(mixinPtr, classPtr->mixins) { - TclOORemoveFromMixinSubs(classPtr, mixinPtr); - TclOODecrRefCount(mixinPtr->thisPtr); - } - classPtr->mixins.list = (Class **)ckrealloc(classPtr->mixins.list, - sizeof(Class *) * numMixins); - } else { - classPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins); - } - classPtr->mixins.num = numMixins; - memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); - FOREACH(mixinPtr, classPtr->mixins) { - TclOOAddToMixinSubs(classPtr, mixinPtr); - - /* - * For the new copy created by memcpy. - */ - - AddRef(mixinPtr->thisPtr); - } - } - BumpGlobalEpoch(interp, classPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * InstallStandardVariableMapping, InstallPrivateVariableMapping -- - * - * Helpers for installing standard and private variable maps. - * - * ---------------------------------------------------------------------- - */ - -static inline void -InstallStandardVariableMapping( - VariableNameList *vnlPtr, - int varc, - Tcl_Obj *const *varv) -{ - Tcl_Obj *variableObj; - int i, n, created; - Tcl_HashTable uniqueTable; - - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, *vnlPtr) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree(vnlPtr->list); - } else if (i) { - vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); - } else { - vnlPtr->list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - vnlPtr->num = 0; - if (varc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - vnlPtr->list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - vnlPtr->num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - if (n != varc) { - vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -static inline void -InstallPrivateVariableMapping( - PrivateVariableList *pvlPtr, - int varc, - Tcl_Obj *const *varv, - int creationEpoch) -{ - PrivateVariableMapping *privatePtr; - int i, n, created; - Tcl_HashTable uniqueTable; - - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH_STRUCT(privatePtr, *pvlPtr) { - Tcl_DecrRefCount(privatePtr->variableObj); - Tcl_DecrRefCount(privatePtr->fullNameObj); - } - if (i != varc) { - if (varc == 0) { - ckfree(pvlPtr->list); - } else if (i) { - pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list, - sizeof(PrivateVariableMapping) * varc); - } else { - pvlPtr->list = (PrivateVariableMapping *)ckalloc(sizeof(PrivateVariableMapping) * varc); - } - } - - pvlPtr->num = 0; - if (varc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - privatePtr = &(pvlPtr->list[n++]); - privatePtr->variableObj = varv[i]; - privatePtr->fullNameObj = Tcl_ObjPrintf( - PRIVATE_VARIABLE_PATTERN, - creationEpoch, Tcl_GetString(varv[i])); - Tcl_IncrRefCount(privatePtr->fullNameObj); - } else { - Tcl_DecrRefCount(varv[i]); - } - } - pvlPtr->num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - if (n != varc) { - pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list, - sizeof(PrivateVariableMapping) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -/* - * ---------------------------------------------------------------------- - * - * RenameDeleteMethod -- - * - * Core of the code to rename and delete methods. - * - * ---------------------------------------------------------------------- - */ - -static int -RenameDeleteMethod( - Tcl_Interp *interp, - Object *oPtr, - int useClass, - Tcl_Obj *const fromPtr, - Tcl_Obj *const toPtr) -{ - Tcl_HashEntry *hPtr, *newHPtr = NULL; - Method *mPtr; - int isNew; - - if (!useClass) { - if (!oPtr->methodsPtr) { - noSuchMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method %s does not exist", TclGetString(fromPtr))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(fromPtr), (void *)NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr); - if (hPtr == NULL) { - goto noSuchMethod; - } - if (toPtr) { - newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr, - &isNew); - if (hPtr == newHPtr) { - renameToSelf: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot rename method to itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", (void *)NULL); - return TCL_ERROR; - } else if (!isNew) { - renameToExisting: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method called %s already exists", - TclGetString(toPtr))); - Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", (void *)NULL); - return TCL_ERROR; - } - } - } else { - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) fromPtr); - if (hPtr == NULL) { - goto noSuchMethod; - } - if (toPtr) { - newHPtr = Tcl_CreateHashEntry(&oPtr->classPtr->classMethods, - (char *) toPtr, &isNew); - if (hPtr == newHPtr) { - goto renameToSelf; - } else if (!isNew) { - goto renameToExisting; - } - } - } - - /* - * Complete the splicing by changing the method's name. - */ - - mPtr = (Method *)Tcl_GetHashValue(hPtr); - if (toPtr) { - Tcl_IncrRefCount(toPtr); - Tcl_DecrRefCount(mPtr->namePtr); - mPtr->namePtr = toPtr; - Tcl_SetHashValue(newHPtr, mPtr); - } else { - if (!useClass) { - RecomputeClassCacheFlag(oPtr); - } - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashEntry(hPtr); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOUnknownDefinition -- - * - * Handles what happens when an unknown command is encountered during the - * processing of a definition script. Works by finding a command in the - * operating definition namespace that the requested command is a unique - * prefix of. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOUnknownDefinition( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - int soughtLen; - const char *soughtStr, *matchedStr = NULL; - - if (objc < 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad call of unknown handler", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", (void *)NULL); - return TCL_ERROR; - } - if (TclOOGetDefineCmdContext(interp) == NULL) { - return TCL_ERROR; - } - - soughtStr = TclGetStringFromObj(objv[1], &soughtLen); - if (soughtLen == 0) { - goto noMatch; - } - hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - while (hPtr != NULL) { - const char *nameStr = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); - - if (strncmp(soughtStr, nameStr, soughtLen) == 0) { - if (matchedStr != NULL) { - goto noMatch; - } - matchedStr = nameStr; - } - hPtr = Tcl_NextHashEntry(&search); - } - - if (matchedStr != NULL) { - /* - * Got one match, and only one match! - */ - - Tcl_Obj **newObjv = (Tcl_Obj **) - TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1)); - int result; - - newObjv[0] = Tcl_NewStringObj(matchedStr, -1); - Tcl_IncrRefCount(newObjv[0]); - if (objc > 2) { - memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2)); - } - result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0); - Tcl_DecrRefCount(newObjv[0]); - TclStackFree(interp, newObjv); - return result; - } - - noMatch: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", soughtStr)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, (void *)NULL); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * FindCommand -- - * - * Specialized version of Tcl_FindCommand that handles command prefixes - * and disallows namespace magic. - * - * ---------------------------------------------------------------------- - */ - -static Tcl_Command -FindCommand( - Tcl_Interp *interp, - Tcl_Obj *stringObj, - Tcl_Namespace *const namespacePtr) -{ - int length; - const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); - Namespace *const nsPtr = (Namespace *) namespacePtr; - FOREACH_HASH_DECLS; - Tcl_Command cmd, cmd2; - - /* - * If someone is playing games, we stop playing right now. - */ - - if (string[0] == '\0' || strstr(string, "::") != NULL) { - return NULL; - } - - /* - * Do the exact lookup first. - */ - - cmd = Tcl_FindCommand(interp, string, namespacePtr, TCL_NAMESPACE_ONLY); - if (cmd != NULL) { - return cmd; - } - - /* - * Bother, need to perform an approximate match. Iterate across the hash - * table of commands in the namespace. - */ - - FOREACH_HASH(nameStr, cmd2, &nsPtr->cmdTable) { - if (strncmp(string, nameStr, length) == 0) { - if (cmd != NULL) { - return NULL; - } - cmd = cmd2; - } - } - - /* - * Either we found one thing or we found nothing. Either way, return it. - */ - - return cmd; -} - -/* - * ---------------------------------------------------------------------- - * - * InitDefineContext -- - * - * Does the magic incantations necessary to push the special stack frame - * used when processing object definitions. It is up to the caller to - * dispose of the frame (with TclPopStackFrame) when finished. - * - * ---------------------------------------------------------------------- - */ - -static inline int -InitDefineContext( - Tcl_Interp *interp, - Tcl_Namespace *namespacePtr, - Object *oPtr, - int objc, - Tcl_Obj *const objv[]) -{ - CallFrame *framePtr, **framePtrPtr = &framePtr; - - if (namespacePtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no definition namespace available", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - /* - * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. - */ - - (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - namespacePtr, FRAME_IS_OO_DEFINE); - framePtr->clientData = oPtr; - framePtr->objc = objc; - framePtr->objv = objv; /* Reference counts do not need to be - * incremented here. */ - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOGetDefineCmdContext -- - * - * Extracts the magic token from the current stack frame, or returns NULL - * (and leaves an error message) otherwise. - * - * ---------------------------------------------------------------------- - */ - -Tcl_Object -TclOOGetDefineCmdContext( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Object object; - - if ((iPtr->varFramePtr == NULL) - || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE - && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "this command may only be called from within the context of" - " an ::oo::define or ::oo::objdefine command", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return NULL; - } - object = (Tcl_Object)iPtr->varFramePtr->clientData; - if (Tcl_ObjectDeleted(object)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "this command cannot be called when the object has been" - " deleted", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return NULL; - } - return object; -} - -/* - * ---------------------------------------------------------------------- - * - * GetClassInOuterContext, GetNamespaceInOuterContext -- - * - * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to - * perform the lookup in the context that called oo::define (or - * equivalent). Note that this may have to go up multiple levels to get - * the level that we started doing definitions at. - * - * ---------------------------------------------------------------------- - */ - -static inline Class * -GetClassInOuterContext( - Tcl_Interp *interp, - Tcl_Obj *className, - const char *errMsg) -{ - Interp *iPtr = (Interp *) interp; - Object *oPtr; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE - || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { - if (iPtr->varFramePtr->callerVarPtr == NULL) { - Tcl_Panic("getting outer context when already in global context"); - } - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, className); - iPtr->varFramePtr = savedFramePtr; - if (oPtr == NULL) { - return NULL; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(className), (void *)NULL); - return NULL; - } - return oPtr->classPtr; -} - -static inline Tcl_Namespace * -GetNamespaceInOuterContext( - Tcl_Interp *interp, - Tcl_Obj *namespaceName) -{ - Interp *iPtr = (Interp *) interp; - Tcl_Namespace *nsPtr; - int result; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE - || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { - if (iPtr->varFramePtr->callerVarPtr == NULL) { - Tcl_Panic("getting outer context when already in global context"); - } - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr); - iPtr->varFramePtr = savedFramePtr; - if (result != TCL_OK) { - return NULL; - } - return nsPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * GenerateErrorInfo -- - * - * Factored out code to generate part of the error trace messages. - * - * ---------------------------------------------------------------------- - */ - -static inline void -GenerateErrorInfo( - Tcl_Interp *interp, /* Where to store the error info trace. */ - Object *oPtr, /* What object (or class) was being configured - * when the error occurred? */ - Tcl_Obj *savedNameObj, /* Name of object saved from before script was - * evaluated, which is needed if the object - * goes away part way through execution. OTOH, - * if the object isn't deleted then its - * current name (post-execution) has to be - * used. This matters, because the object - * could have been renamed... */ - const char *typeOfSubject) /* Part of the message, saying whether it was - * an object, class or class-as-object that - * was being configured. */ -{ - int length; - Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) - ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = TclGetStringFromObj(realNameObj, &length); - int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for %s \"%.*s%s\" line %d)", - typeOfSubject, (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); -} - -/* - * ---------------------------------------------------------------------- - * - * MagicDefinitionInvoke -- - * - * Part of the implementation of the "oo::define" and "oo::objdefine" - * commands that is used to implement the more-than-one-argument case, - * applying ensemble-like tricks with dispatch so that error messages are - * clearer. Doesn't handle the management of the stack frame. - * - * ---------------------------------------------------------------------- - */ - -static inline int -MagicDefinitionInvoke( - Tcl_Interp *interp, - Tcl_Namespace *nsPtr, - int cmdIndex, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Tcl_Command cmd; - int isRoot, dummy, result, offset = cmdIndex + 1; - - /* - * More than one argument: fire them through the ensemble processing - * engine so that everything appears to be good and proper in error - * messages. Note that we cannot just concatenate and send through - * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go - * through Tcl_EvalObjv without the extra work to pre-find the command, as - * that finds command names in the wrong namespace at the moment. Ugly! - */ - - isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv); - - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ - - TclNewObj(objPtr); - TclNewObj(obj2Ptr); - cmd = FindCommand(interp, objv[cmdIndex], nsPtr); - if (cmd == NULL) { - /* - * Punt this case! - */ - - Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - /* TODO: overflow? */ - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc - offset, objv + offset); - TclListObjGetElements(NULL, objPtr, &dummy, &objs); - - result = Tcl_EvalObjv(interp, objc - cmdIndex, objs, TCL_EVAL_INVOKE); - if (isRoot) { - TclResetRewriteEnsemble(interp, 1); - } - Tcl_DecrRefCount(objPtr); - - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineObjCmd -- - * - * Implementation of the "oo::define" command. Works by effectively doing - * the same as 'namespace eval', but with extra magic applied so that the - * object to be modified is known to the commands in the target - * namespace. Also does ensemble-like tricks with dispatch so that error - * messages are clearer. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Namespace *nsPtr; - Object *oPtr; - int result; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s does not refer to a class", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[1]), (void *)NULL); - return TCL_ERROR; - } - - /* - * Make the oo::define namespace the current namespace and evaluate the - * command(s). - */ - - nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1); - if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - - AddRef(oPtr); - if (objc == 3) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[2], 0, - ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, "class"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOOObjDefObjCmd -- - * - * Implementation of the "oo::objdefine" command. Works by effectively - * doing the same as 'namespace eval', but with extra magic applied so - * that the object to be modified is known to the commands in the target - * namespace. Also does ensemble-like tricks with dispatch so that error - * messages are clearer. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOObjDefObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Namespace *nsPtr; - Object *oPtr; - int result; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); - if (oPtr == NULL) { - return TCL_ERROR; - } - - /* - * Make the oo::objdefine namespace the current namespace and evaluate the - * command(s). - */ - - nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); - if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - - AddRef(oPtr); - if (objc == 3) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[2], 0, - ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, "object"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineSelfObjCmd -- - * - * Implementation of the "self" subcommand of the "oo::define" command. - * Works by effectively doing the same as 'namespace eval', but with - * extra magic applied so that the object to be modified is known to the - * commands in the target namespace. Also does ensemble-like tricks with - * dispatch so that error messages are clearer. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineSelfObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Tcl_Namespace *nsPtr; - Object *oPtr; - int result, isPrivate; - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - - if (objc < 2) { - Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); - return TCL_OK; - } - - isPrivate = IsPrivateDefine(interp); - - /* - * Make the oo::objdefine namespace the current namespace and evaluate the - * command(s). - */ - - nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); - if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - if (isPrivate) { - ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; - } - - AddRef(oPtr); - if (objc == 2) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 1); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineObjSelfObjCmd -- - * - * Implementation of the "self" subcommand of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineObjSelfObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefinePrivateObjCmd -- - * - * Implementation of the "private" subcommand of the "oo::define" - * and "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefinePrivateObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstancePrivate = (clientData != NULL); - /* Just so that we can generate the correct - * error message depending on the context of - * usage of this function. */ - Interp *iPtr = (Interp *) interp; - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int saved; /* The saved flag. We restore it on exit so - * that [private private ...] doesn't make - * things go weird. */ - int result; - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); - return TCL_OK; - } - - /* - * Change the frame type flag while evaluating the body. - */ - - saved = iPtr->varFramePtr->isProcCallFrame; - iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME; - - /* - * Evaluate the body; standard pattern. - */ - - AddRef(oPtr); - if (objc == 2) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, - isInstancePrivate ? "object" : "class"); - } - TclDecrRefCount(objNameObj); - } else { - result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp), - 1, objc, objv); - } - TclOODecrRefCount(oPtr); - - /* - * Restore the frame type flag to what it was previously. - */ - - iPtr->varFramePtr->isProcCallFrame = saved; - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineClassObjCmd -- - * - * Implementation of the "class" subcommand of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineClassObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - Class *clsPtr; - Foundation *fPtr = TclOOGetFoundation(interp); - int wasClass, willBeClass; - - /* - * Parse the context to get the object to operate on. - */ - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->flags & ROOT_OBJECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the class of the root object class", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - if (oPtr->flags & ROOT_CLASS) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the class of the class of classes", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - /* - * Parse the argument to get the class to set the object's class to. - */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); - return TCL_ERROR; - } - clsPtr = GetClassInOuterContext(interp, objv[1], - "the class of an object must be a class"); - if (clsPtr == NULL) { - return TCL_ERROR; - } - if (oPtr == clsPtr->thisPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not change classes into an instance of themselves", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - /* - * Set the object's class. - */ - - wasClass = (oPtr->classPtr != NULL); - willBeClass = (TclOOIsReachable(fPtr->classCls, clsPtr)); - - if (oPtr->selfCls != clsPtr) { - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - TclOODecrRefCount(oPtr->selfCls->thisPtr); - oPtr->selfCls = clsPtr; - AddRef(oPtr->selfCls->thisPtr); - TclOOAddToInstances(oPtr, oPtr->selfCls); - - /* - * Create or delete the class guts if necessary. - */ - - if (wasClass && !willBeClass) { - /* - * This is the most global of all epochs. Bump it! No cache can be - * trusted! - */ - - TclOORemoveFromMixins(oPtr->classPtr, oPtr); - oPtr->fPtr->epoch++; - oPtr->flags |= DONT_DELETE; - TclOODeleteDescendants(interp, oPtr); - oPtr->flags &= ~DONT_DELETE; - TclOOReleaseClassContents(interp, oPtr); - ckfree(oPtr->classPtr); - oPtr->classPtr = NULL; - } else if (!wasClass && willBeClass) { - TclOOAllocClass(interp, oPtr); - } - - if (oPtr->classPtr != NULL) { - BumpGlobalEpoch(interp, oPtr->classPtr); - } else { - BumpInstanceEpoch(oPtr); - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineConstructorObjCmd -- - * - * Implementation of the "constructor" subcommand of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineConstructorObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - Class *clsPtr; - Tcl_Method method; - int bodyLength; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "arguments body"); - return TCL_ERROR; - } - - /* - * Extract and validate the context, which is the class that we wish to - * modify. - */ - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - clsPtr = oPtr->classPtr; - - TclGetStringFromObj(objv[2], &bodyLength); - if (bodyLength > 0) { - /* - * Create the method structure. - */ - - method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, - PUBLIC_METHOD, NULL, objv[1], objv[2], NULL); - if (method == NULL) { - return TCL_ERROR; - } - } else { - /* - * Delete the constructor method record and set the field in the - * class record to NULL. - */ - - method = NULL; - } - - /* - * Place the method structure in the class record. Note that we might not - * immediately delete the constructor as this might be being done during - * execution of the constructor itself. - */ - - Tcl_ClassSetConstructor(interp, (Tcl_Class) clsPtr, method); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineDefnNsObjCmd -- - * - * Implementation of the "definitionnamespace" subcommand of the - * "oo::define" command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDefnNsObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - static const char *kindList[] = { - "-class", - "-instance", - NULL - }; - int kind = 0; - Object *oPtr; - Tcl_Namespace *nsPtr; - Tcl_Obj *nsNamePtr, **storagePtr; - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the definition namespace of the root classes", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - /* - * Parse the arguments and work out what the user wants to do. - */ - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace"); - return TCL_ERROR; - } - if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0, - &kind) != TCL_OK) { - return TCL_ERROR; - } - if (!Tcl_GetString(objv[objc - 1])[0]) { - nsNamePtr = NULL; - } else { - nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); - if (nsPtr == NULL) { - return TCL_ERROR; - } - nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1); - Tcl_IncrRefCount(nsNamePtr); - } - - /* - * Update the correct field of the class definition. - */ - - if (kind) { - storagePtr = &oPtr->classPtr->objDefinitionNs; - } else { - storagePtr = &oPtr->classPtr->clsDefinitionNs; - } - if (*storagePtr != NULL) { - Tcl_DecrRefCount(*storagePtr); - } - *storagePtr = nsNamePtr; - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineDeleteMethodObjCmd -- - * - * Implementation of the "deletemethod" subcommand of the "oo::define" - * and "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDeleteMethodObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceDeleteMethod = (clientData != NULL); - Object *oPtr; - int i; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceDeleteMethod && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - for (i = 1; i < objc; i++) { - /* - * Delete the method structure from the appropriate hash table. - */ - - if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod, - objv[i], NULL) != TCL_OK) { - return TCL_ERROR; - } - } - - if (isInstanceDeleteMethod) { - BumpInstanceEpoch(oPtr); - } else { - BumpGlobalEpoch(interp, oPtr->classPtr); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineDestructorObjCmd -- - * - * Implementation of the "destructor" subcommand of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDestructorObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - Class *clsPtr; - Tcl_Method method; - int bodyLength; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "body"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - clsPtr = oPtr->classPtr; - - TclGetStringFromObj(objv[1], &bodyLength); - if (bodyLength > 0) { - /* - * Create the method structure. - */ - - method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr, - PUBLIC_METHOD, NULL, NULL, objv[1], NULL); - if (method == NULL) { - return TCL_ERROR; - } - } else { - /* - * Delete the destructor method record and set the field in the class - * record to NULL. - */ - - method = NULL; - } - - /* - * Place the method structure in the class record. Note that we might not - * immediately delete the destructor as this might be being done during - * execution of the destructor itself. Also note that setting a - * destructor during a destructor is fairly dumb anyway. - */ - - Tcl_ClassSetDestructor(interp, (Tcl_Class) clsPtr, method); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineExportObjCmd -- - * - * Implementation of the "export" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineExportObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceExport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - clsPtr = oPtr->classPtr; - if (!isInstanceExport && !clsPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - for (i = 1; i < objc; i++) { - /* - * Exporting is done by adding the PUBLIC_METHOD flag to 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 with that flag; such - * records are skipped over by the call chain engine *except* for - * their flags member. - */ - - if (isInstanceExport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *)ckalloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *)Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { - mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; - changed = 1; - } - } - - /* - * Bump the right epoch if we actually changed anything. - */ - - if (changed) { - if (isInstanceExport) { - BumpInstanceEpoch(oPtr); - } else { - BumpGlobalEpoch(interp, clsPtr); - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineForwardObjCmd -- - * - * Implementation of the "forward" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineForwardObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceForward = (clientData != NULL); - Object *oPtr; - Method *mPtr; - int isPublic; - Tcl_Obj *prefixObj; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name cmdName ?arg ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceForward && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) - ? PUBLIC_METHOD : 0; - if (IsPrivateDefine(interp)) { - isPublic = TRUE_PRIVATE_METHOD; - } - - /* - * Create the method structure. - */ - - prefixObj = Tcl_NewListObj(objc - 2, objv + 2); - if (isInstanceForward) { - mPtr = TclOONewForwardInstanceMethod(interp, oPtr, isPublic, objv[1], - prefixObj); - } else { - mPtr = TclOONewForwardMethod(interp, oPtr->classPtr, isPublic, - objv[1], prefixObj); - } - if (mPtr == NULL) { - Tcl_DecrRefCount(prefixObj); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineMethodObjCmd -- - * - * Implementation of the "method" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineMethodObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - /* - * Table of export modes for methods and their corresponding enum. - */ - - static const char *const exportModes[] = { - "-export", - "-private", - "-unexport", - NULL - }; - enum ExportMode { - MODE_EXPORT, - MODE_PRIVATE, - MODE_UNEXPORT - } exportMode; - - int isInstanceMethod = (clientData != NULL); - Object *oPtr; - int isPublic = 0; - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceMethod && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - if (objc == 5) { - if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", - 0, &exportMode) != TCL_OK) { - return TCL_ERROR; - } - switch (exportMode) { - case MODE_EXPORT: - isPublic = PUBLIC_METHOD; - break; - case MODE_PRIVATE: - isPublic = TRUE_PRIVATE_METHOD; - break; - case MODE_UNEXPORT: - isPublic = 0; - break; - } - } else { - if (IsPrivateDefine(interp)) { - isPublic = TRUE_PRIVATE_METHOD; - } else { - isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) - ? PUBLIC_METHOD : 0; - } - } - - /* - * Create the method by using the right back-end API. - */ - - if (isInstanceMethod) { - if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { - return TCL_ERROR; - } - } else { - if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], - objv[objc - 2], objv[objc - 1], NULL) == NULL) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineRenameMethodObjCmd -- - * - * Implementation of the "renamemethod" subcommand of the "oo::define" - * and "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineRenameMethodObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceRenameMethod = (clientData != NULL); - Object *oPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceRenameMethod && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - /* - * Delete the method entry from the appropriate hash table, and transfer - * the thing it points to to its new entry. To do this, we first need to - * get the entries from the appropriate hash tables (this can generate a - * range of errors...) - */ - - if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod, - objv[1], objv[2]) != TCL_OK) { - return TCL_ERROR; - } - - if (isInstanceRenameMethod) { - BumpInstanceEpoch(oPtr); - } else { - BumpGlobalEpoch(interp, oPtr->classPtr); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineUnexportObjCmd -- - * - * Implementation of the "unexport" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineUnexportObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - int isInstanceUnexport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - clsPtr = oPtr->classPtr; - if (!isInstanceUnexport && !clsPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - for (i = 1; i < objc; i++) { - /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the - * method record. If there is no such method in this object or class - * (i.e. the method comes from something inherited from or that we're - * an instance of) then we put in a blank record without that flag; - * such records are skipped over by the call chain engine *except* for - * their flags member. - */ - - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *)ckalloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *)Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - changed = 1; - } - } - - /* - * Bump the right epoch if we actually changed anything. - */ - - if (changed) { - if (isInstanceUnexport) { - BumpInstanceEpoch(oPtr); - } else { - BumpGlobalEpoch(interp, clsPtr); - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- - * - * How to install a constructor or destructor into a class; API to call - * from C. - * - * ---------------------------------------------------------------------- - */ - -void -Tcl_ClassSetConstructor( - Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) -{ - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->constructorPtr) { - TclOODelMethodRef(clsPtr->constructorPtr); - clsPtr->constructorPtr = (Method *) method; - - /* - * Remember to invalidate the cached constructor chain for this class. - * [Bug 2531577] - */ - - if (clsPtr->constructorChainPtr) { - TclOODeleteChain(clsPtr->constructorChainPtr); - clsPtr->constructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); - } -} - -void -Tcl_ClassSetDestructor( - Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) -{ - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->destructorPtr) { - TclOODelMethodRef(clsPtr->destructorPtr); - clsPtr->destructorPtr = (Method *) method; - if (clsPtr->destructorChainPtr) { - TclOODeleteChain(clsPtr->destructorChainPtr); - clsPtr->destructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineSlots -- - * - * Create the "::oo::Slot" class and its standard instances. Class - * definition is empty at the stage (added by scripting). - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineSlots( - Foundation *fPtr) -{ - const struct DeclaredSlot *slotInfoPtr; - Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); - Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); - Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); - Class *slotCls; - - slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) - fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; - if (slotCls == NULL) { - return TCL_ERROR; - } - Tcl_IncrRefCount(getName); - Tcl_IncrRefCount(setName); - Tcl_IncrRefCount(resolveName); - for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { - Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); - - if (slotObject == NULL) { - continue; - } - Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, - &slotInfoPtr->getterType, NULL); - Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, - &slotInfoPtr->setterType, NULL); - if (slotInfoPtr->resolverType.callProc) { - Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, - &slotInfoPtr->resolverType, NULL); - } - } - Tcl_DecrRefCount(getName); - Tcl_DecrRefCount(setName); - Tcl_DecrRefCount(resolveName); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassFilterGet, ClassFilterSet -- - * - * Implementation of the "filter" slot accessors of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ClassFilterGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *filterObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(filterObj, oPtr->classPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassFilterSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; - Tcl_Obj **filterv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } else if (TclListObjGetElements(interp, objv[0], &filterc, - &filterv) != TCL_OK) { - return TCL_ERROR; - } - - TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassMixinGet, ClassMixinSet -- - * - * Implementation of the "mixin" slot accessors of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ClassMixinGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - Class *mixinPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(mixinPtr, oPtr->classPtr->mixins) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - -} - -static int -ClassMixinSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc, i, isNew; - Tcl_Obj **mixinv; - Class **mixins;; /* The references to the classes to actually - * install. */ - Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a - * set of class references; it has no payload - * values and keys are always pointers. */ - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "mixinList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } else if (TclListObjGetElements(interp, objv[0], &mixinc, - &mixinv) != TCL_OK) { - return TCL_ERROR; - } - - mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc); - Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS); - - for (i = 0; i < mixinc; i++) { - mixins[i] = GetClassInOuterContext(interp, mixinv[i], - "may only mix in classes"); - if (mixins[i] == NULL) { - i--; - goto freeAndError; - } - (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew); - if (!isNew) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "class should only be a direct mixin once", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); - goto freeAndError; - } - if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", (void *)NULL); - goto freeAndError; - } - } - - TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); - Tcl_DeleteHashTable(&uniqueCheck); - TclStackFree(interp, mixins); - return TCL_OK; - - freeAndError: - Tcl_DeleteHashTable(&uniqueCheck); - TclStackFree(interp, mixins); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassSuperGet, ClassSuperSet -- - * - * Implementation of the "superclass" slot accessors of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ClassSuperGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - Class *superPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(superPtr, oPtr->classPtr->superclasses) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, superPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassSuperSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int superc, i, j; - Tcl_Obj **superv; - Class **superclasses, *superPtr; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "superclassList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not modify the superclass of the root object", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } else if (TclListObjGetElements(interp, objv[0], &superc, - &superv) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Allocate some working space. - */ - - superclasses = (Class **) ckalloc(sizeof(Class *) * superc); - - /* - * Parse the arguments to get the class to use as superclasses. - * - * Note that zero classes is special, as it is equivalent to just the - * class of objects. [Bug 9d61624b3d] - */ - - if (superc == 0) { - superclasses = (Class **)ckrealloc(superclasses, sizeof(Class *)); - if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { - superclasses[0] = oPtr->fPtr->classCls; - } else { - superclasses[0] = oPtr->fPtr->objectCls; - } - superc = 1; - AddRef(superclasses[0]->thisPtr); - } else { - for (i = 0; i < superc; i++) { - superclasses[i] = GetClassInOuterContext(interp, superv[i], - "only a class can be a superclass"); - if (superclasses[i] == NULL) { - goto failedAfterAlloc; - } - for (j = 0; j < i; j++) { - if (superclasses[j] == superclasses[i]) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "class should only be a direct superclass once", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",(void *)NULL); - goto failedAfterAlloc; - } - } - if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to form circular dependency graph", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", (void *)NULL); - failedAfterAlloc: - for (; i-- > 0 ;) { - TclOODecrRefCount(superclasses[i]->thisPtr); - } - ckfree(superclasses); - return TCL_ERROR; - } - - /* - * Corresponding TclOODecrRefCount() is near the end of this - * function. - */ - - AddRef(superclasses[i]->thisPtr); - } - } - - /* - * Install the list of superclasses into the class. Note that this also - * involves splicing the class out of the superclasses' subclass list that - * it used to be a member of and splicing it into the new superclasses' - * subclass list. - */ - - if (oPtr->classPtr->superclasses.num != 0) { - FOREACH(superPtr, oPtr->classPtr->superclasses) { - TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); - TclOODecrRefCount(superPtr->thisPtr); - } - ckfree(oPtr->classPtr->superclasses.list); - } - oPtr->classPtr->superclasses.list = superclasses; - oPtr->classPtr->superclasses.num = superc; - FOREACH(superPtr, oPtr->classPtr->superclasses) { - TclOOAddToSubclasses(oPtr->classPtr, superPtr); - } - BumpGlobalEpoch(interp, oPtr->classPtr); - - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassVarsGet, ClassVarsSet -- - * - * Implementation of the "variable" slot accessors of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ClassVarsGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - if (IsPrivateDefine(interp)) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassVarsSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc; - Tcl_Obj **varv; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } else if (TclListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - for (i = 0; i < varc; i++) { - const char *varName = TclGetString(varv[i]); - - if (strstr(varName, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "contain namespace separators")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); - return TCL_ERROR; - } - if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "refer to an array element")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); - return TCL_ERROR; - } - } - - if (IsPrivateDefine(interp)) { - InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables, - varc, varv, oPtr->classPtr->thisPtr->creationEpoch); - } else { - InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectFilterGet, ObjectFilterSet -- - * - * Implementation of the "filter" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjFilterGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *filterObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(filterObj, oPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjFilterSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; - Tcl_Obj **filterv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements(interp, objv[0], &filterc, - &filterv) != TCL_OK) { - return TCL_ERROR; - } - - TclOOObjectSetFilters(oPtr, filterc, filterv); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectMixinGet, ObjectMixinSet -- - * - * Implementation of the "mixin" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjMixinGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - Class *mixinPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjMixinSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc, i, isNew; - Tcl_Obj **mixinv; - Class **mixins; /* The references to the classes to actually - * install. */ - Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a - * set of class references; it has no payload - * values and keys are always pointers. */ - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "mixinList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements(interp, objv[0], &mixinc, - &mixinv) != TCL_OK) { - return TCL_ERROR; - } - - mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc); - Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS); - - for (i = 0; i < mixinc; i++) { - mixins[i] = GetClassInOuterContext(interp, mixinv[i], - "may only mix in classes"); - if (mixins[i] == NULL) { - goto freeAndError; - } - (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew); - if (!isNew) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "class should only be a direct mixin once", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); - goto freeAndError; - } - } - - TclOOObjectSetMixins(oPtr, mixinc, mixins); - TclStackFree(interp, mixins); - Tcl_DeleteHashTable(&uniqueCheck); - return TCL_OK; - - freeAndError: - TclStackFree(interp, mixins); - Tcl_DeleteHashTable(&uniqueCheck); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectVarsGet, ObjectVarsSet -- - * - * Implementation of the "variable" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjVarsGet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - if (IsPrivateDefine(interp)) { - PrivateVariableMapping *privatePtr; - - FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { - Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); - } - } else { - Tcl_Obj *variableObj; - - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjVarsSet( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc, i; - Tcl_Obj **varv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "variableList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (TclListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - for (i = 0; i < varc; i++) { - const char *varName = TclGetString(varv[i]); - - if (strstr(varName, "::") != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "contain namespace separators")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); - return TCL_ERROR; - } - if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid declared variable name \"%s\": must not %s", - varName, "refer to an array element")); - Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", (void *)NULL); - return TCL_ERROR; - } - } - - if (IsPrivateDefine(interp)) { - InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, - oPtr->creationEpoch); - } else { - InstallStandardVariableMapping(&oPtr->variables, varc, varv); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ResolveClass -- - * - * Implementation of the "Resolve" support method for some slots (those - * that are slots around a list of classes). This resolves possible class - * names to their fully-qualified names if possible. - * - * ---------------------------------------------------------------------- - */ - -static int -ResolveClass( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - int idx = Tcl_ObjectContextSkippedArgs(context); - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Class *clsPtr; - - /* - * Check if were called wrongly. The definition context isn't used... - * except that GetClassInOuterContext() assumes that it is there. - */ - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (objc != idx + 1) { - Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); - return TCL_ERROR; - } - - /* - * Resolve the class if possible. If not, remove any resolution error and - * return what we've got anyway as the failure might not be fatal overall. - */ - - clsPtr = GetClassInOuterContext(interp, objv[idx], - "USER SHOULD NOT SEE THIS MESSAGE"); - if (clsPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, objv[idx]); - } else { - Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); - } - - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet -- - * - * Implementations of the "readableproperties" slot accessors for classes - * and instances. - * - * ---------------------------------------------------------------------- - */ - -static void -InstallReadableProps( - PropertyStorage *props, - Tcl_Size objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *propObj; - Tcl_Size i, n; - int created; - Tcl_HashTable uniqueTable; - - if (props->allReadableCache) { - Tcl_DecrRefCount(props->allReadableCache); - props->allReadableCache = NULL; - } - - for (i=0 ; i<objc ; i++) { - Tcl_IncrRefCount(objv[i]); - } - FOREACH(propObj, props->readable) { - Tcl_DecrRefCount(propObj); - } - if (i != objc) { - if (objc == 0) { - ckfree(props->readable.list); - } else if (i) { - props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, - sizeof(Tcl_Obj *) * objc); - } else { - props->readable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); - } - } - props->readable.num = 0; - if (objc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<objc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, objv[i], &created); - if (created) { - props->readable.list[n++] = objv[i]; - } else { - Tcl_DecrRefCount(objv[i]); - } - } - props->readable.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - if (n != objc) { - props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, - sizeof(Tcl_Obj *) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -static int -ClassRPropsGet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *propNameObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(propNameObj, oPtr->classPtr->properties.readable) { - Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassRPropsSet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size varc; - Tcl_Obj **varv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - InstallReadableProps(&oPtr->classPtr->properties, varc, varv); - BumpGlobalEpoch(interp, oPtr->classPtr); - return TCL_OK; -} - -static int -ObjRPropsGet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *propNameObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(propNameObj, oPtr->properties.readable) { - Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjRPropsSet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size varc; - Tcl_Obj **varv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - InstallReadableProps(&oPtr->properties, varc, varv); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet -- - * - * Implementations of the "writableproperties" slot accessors for classes - * and instances. - * - * ---------------------------------------------------------------------- - */ - -static void -InstallWritableProps( - PropertyStorage *props, - Tcl_Size objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *propObj; - Tcl_Size i, n; - int created; - Tcl_HashTable uniqueTable; - - if (props->allWritableCache) { - Tcl_DecrRefCount(props->allWritableCache); - props->allWritableCache = NULL; - } - - for (i=0 ; i<objc ; i++) { - Tcl_IncrRefCount(objv[i]); - } - FOREACH(propObj, props->writable) { - Tcl_DecrRefCount(propObj); - } - if (i != objc) { - if (objc == 0) { - ckfree(props->writable.list); - } else if (i) { - props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, - sizeof(Tcl_Obj *) * objc); - } else { - props->writable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); - } - } - props->writable.num = 0; - if (objc > 0) { - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<objc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, objv[i], &created); - if (created) { - props->writable.list[n++] = objv[i]; - } else { - Tcl_DecrRefCount(objv[i]); - } - } - props->writable.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - if (n != objc) { - props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, - sizeof(Tcl_Obj *) * n); - } - Tcl_DeleteHashTable(&uniqueTable); - } -} - -static int -ClassWPropsGet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *propNameObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(propNameObj, oPtr->classPtr->properties.writable) { - Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassWPropsSet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size varc; - Tcl_Obj **varv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "propertyList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (void *)NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - InstallWritableProps(&oPtr->classPtr->properties, varc, varv); - BumpGlobalEpoch(interp, oPtr->classPtr); - return TCL_OK; -} - -static int -ObjWPropsGet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *propNameObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } - - TclNewObj(resultObj); - FOREACH(propNameObj, oPtr->properties.writable) { - Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjWPropsSet( - TCL_UNUSED(void *), - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size varc; - Tcl_Obj **varv; - - if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "propertyList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - InstallWritableProps(&oPtr->properties, varc, varv); - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |