diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 2697 |
1 files changed, 0 insertions, 2697 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c deleted file mode 100644 index 5a6c0ad..0000000 --- a/generic/tclOODefineCmds.c +++ /dev/null @@ -1,2697 +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 (c) 2006-2013 by 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 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; -}; - -#define SLOT(name,getter,setter) \ - {"::oo::" name, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ - getter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}} - -/* - * Forward declarations. - */ - -static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); -static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, - Tcl_Namespace *const namespacePtr); -static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, - Tcl_Obj *savedNameObj, const char *typeOfSubject); -static inline Class * GetClassInOuterContext(Tcl_Interp *interp, - Tcl_Obj *className, const char *errMsg); -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 int ClassFilterGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassFilterSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassMixinGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassMixinSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassSuperGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassSuperSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassVarsGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassVarsSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjFilterGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjFilterSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjMixinGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjMixinSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjVarsGet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjVarsSet(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); - -/* - * Now define the slots used in declarations. - */ - -static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet), - SLOT("define::variable", ClassVarsGet, ClassVarsSet), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} -}; - -/* - * ---------------------------------------------------------------------- - * - * 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++; - } - return; - } - - /* - * Either there's no class (?!) or we're reconfiguring something that is - * in use. Force regeneration of call chains. - */ - - TclOOGetFoundation(interp)->epoch++; -} - -/* - * ---------------------------------------------------------------------- - * - * 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 = ckalloc(size); - } else { - filtersList = 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; - } - oPtr->epoch++; /* 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 = ckalloc(size); - } else { - filtersList = 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); - } - ckfree(oPtr->mixins.list); - oPtr->mixins.num = 0; - } - RecomputeClassCacheFlag(oPtr); - } else { - if (oPtr->mixins.num != 0) { - FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr != oPtr->selfCls) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } - } - oPtr->mixins.list = ckrealloc(oPtr->mixins.list, - sizeof(Class *) * numMixins); - } else { - oPtr->mixins.list = 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); - } - } - } - oPtr->epoch++; -} - -/* - * ---------------------------------------------------------------------- - * - * 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); - } - ckfree(classPtr->mixins.list); - classPtr->mixins.num = 0; - } - } else { - if (classPtr->mixins.num != 0) { - FOREACH(mixinPtr, classPtr->mixins) { - TclOORemoveFromMixinSubs(classPtr, mixinPtr); - } - classPtr->mixins.list = ckrealloc(classPtr->mixins.list, - sizeof(Class *) * numMixins); - } else { - classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); - } - classPtr->mixins.num = numMixins; - memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); - FOREACH(mixinPtr, classPtr->mixins) { - TclOOAddToMixinSubs(classPtr, mixinPtr); - } - } - BumpGlobalEpoch(interp, classPtr); -} - -/* - * ---------------------------------------------------------------------- - * - * 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), 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", 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", 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 = 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( - ClientData 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", NULL); - return TCL_ERROR; - } - if (TclOOGetDefineCmdContext(interp) == NULL) { - return TCL_ERROR; - } - - soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); - if (soughtLen == 0) { - goto noMatch; - } - hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - while (hPtr != NULL) { - const char *nameStr = 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 = 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, 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 = Tcl_GetStringFromObj(stringObj, &length); - register 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; - int result; - - if (namespacePtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot process definitions; support namespace deleted", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ - - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, - namespacePtr, FRAME_IS_OO_DEFINE); - if (result != TCL_OK) { - return TCL_ERROR; - } - 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)) { - 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", NULL); - return NULL; - } - 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", NULL); - return NULL; - } - return object; -} - -/* - * ---------------------------------------------------------------------- - * - * GetClassInOuterContext -- - * Wrapper round Tcl_GetObjectFromObj 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) { - 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), NULL); - return NULL; - } - return oPtr->classPtr; -} - -/* - * ---------------------------------------------------------------------- - * - * GenerateErrorInfo -- - * Factored out code to generate part of the error trace messages. - * - * ---------------------------------------------------------------------- - */ - -static 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 = Tcl_GetStringFromObj(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))); -} - -/* - * ---------------------------------------------------------------------- - * - * 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( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Foundation *fPtr = TclOOGetFoundation(interp); - int result; - Object *oPtr; - - 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]), NULL); - return TCL_ERROR; - } - - /* - * Make the oo::define namespace the current namespace and evaluate the - * command(s). - */ - - if (InitDefineContext(interp, fPtr->defineNs, 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 { - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; - Tcl_Command cmd; - int dummy; - - /* - * 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! - */ - - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 3; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 3) { - iPtr->ensembleRewrite.numRemovedObjs += 3 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 2; - } - } - - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ - - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); - cmd = FindCommand(interp, objv[2], fPtr->defineNs); - if (cmd == NULL) { - /* punt this case! */ - Tcl_AppendObjToObj(obj2Ptr, objv[2]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - - result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); - Tcl_DecrRefCount(objPtr); - } - DelRef(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( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Foundation *fPtr = TclOOGetFoundation(interp); - int result; - Object *oPtr; - - 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). - */ - - if (InitDefineContext(interp, fPtr->objdefNs, 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 { - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; - Tcl_Command cmd; - int dummy; - - /* - * 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! - */ - - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 3; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 3) { - iPtr->ensembleRewrite.numRemovedObjs += 3 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 2; - } - } - - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ - - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); - cmd = FindCommand(interp, objv[2], fPtr->objdefNs); - if (cmd == NULL) { - /* punt this case! */ - Tcl_AppendObjToObj(obj2Ptr, objv[2]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - - result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); - Tcl_DecrRefCount(objPtr); - } - DelRef(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( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Foundation *fPtr = TclOOGetFoundation(interp); - int result; - Object *oPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); - return TCL_ERROR; - } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); - if (oPtr == NULL) { - return TCL_ERROR; - } - - /* - * Make the oo::objdefine namespace the current namespace and evaluate the - * command(s). - */ - - if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ - return TCL_ERROR; - } - - AddRef(oPtr); - if (objc == 2) { - Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); - - Tcl_IncrRefCount(objNameObj); - result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); - } - TclDecrRefCount(objNameObj); - } else { - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; - Tcl_Command cmd; - int dummy; - - /* - * 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! - */ - - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 2; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 2) { - iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 1; - } - } - - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ - - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); - cmd = FindCommand(interp, objv[1], fPtr->objdefNs); - if (cmd == NULL) { - /* punt this case! */ - Tcl_AppendObjToObj(obj2Ptr, objv[1]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - - result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE); - Tcl_DecrRefCount(objPtr); - } - DelRef(oPtr); - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineClassObjCmd -- - * Implementation of the "class" subcommand of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineClassObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr; - Class *clsPtr; - Foundation *fPtr = TclOOGetFoundation(interp); - - /* - * 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", 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", 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; - } - - /* - * Apply semantic checks. In particular, classes and non-classes are not - * interchangable (too complicated to do the conversion!) so we must - * produce an error if any attempt is made to swap from one to the other. - */ - - if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "may not change a %sclass object into a %sclass object", - (oPtr->classPtr==NULL ? "non-" : ""), - (oPtr->classPtr==NULL ? "" : "non-"))); - Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); - return TCL_ERROR; - } - - /* - * Set the object's class. - */ - - if (oPtr->selfCls != clsPtr) { - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - oPtr->selfCls = clsPtr; - TclOOAddToInstances(oPtr, oPtr->selfCls); - if (oPtr->classPtr != NULL) { - BumpGlobalEpoch(interp, oPtr->classPtr); - } else { - oPtr->epoch++; - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineConstructorObjCmd -- - * Implementation of the "constructor" subcommand of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineConstructorObjCmd( - ClientData 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; - - Tcl_GetStringFromObj(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; -} - -/* - * ---------------------------------------------------------------------- - * - * 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", 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) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, oPtr->classPtr); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineDestructorObjCmd -- - * Implementation of the "destructor" subcommand of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineDestructorObjCmd( - ClientData 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; - - Tcl_GetStringFromObj(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", 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 = ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], - &isNew); - } - - if (isNew) { - mPtr = ckalloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & PUBLIC_METHOD)) { - mPtr->flags |= PUBLIC_METHOD; - changed = 1; - } - } - - /* - * Bump the right epoch if we actually changed anything. - */ - - if (changed) { - if (isInstanceExport) { - oPtr->epoch++; - } 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", NULL); - return TCL_ERROR; - } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") - ? PUBLIC_METHOD : 0; - - /* - * 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) -{ - int isInstanceMethod = (clientData != NULL); - Object *oPtr; - int isPublic; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "name 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", NULL); - return TCL_ERROR; - } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") - ? PUBLIC_METHOD : 0; - - /* - * Create the method by using the right back-end API. - */ - - if (isInstanceMethod) { - if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], - objv[2], objv[3], NULL) == NULL) { - return TCL_ERROR; - } - } else { - if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], - objv[2], objv[3], NULL) == NULL) { - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineMixinObjCmd -- - * Implementation of the "mixin" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineMixinObjCmd( - ClientData clientData, - Tcl_Interp *interp, - const int objc, - Tcl_Obj *const *objv) -{ - int isInstanceMixin = (clientData != NULL); - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Class **mixins; - int i; - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); - - for (i=1 ; i<objc ; i++) { - Class *clsPtr = GetClassInOuterContext(interp, objv[i], - "may only mix in classes"); - - if (clsPtr == NULL) { - goto freeAndError; - } - if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); - goto freeAndError; - } - mixins[i-1] = clsPtr; - } - - if (isInstanceMixin) { - TclOOObjectSetMixins(oPtr, objc-1, mixins); - } else { - TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); - } - - TclStackFree(interp, mixins); - return TCL_OK; - - freeAndError: - TclStackFree(interp, mixins); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * 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", 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) { - oPtr->epoch++; - } 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", NULL); - return TCL_ERROR; - } - - for (i=1 ; i<objc ; i++) { - /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the - * method record. If there is no such method in this object or class - * (i.e. the method comes from something inherited from or that we're - * an instance of) then we put in a blank record without that flag; - * such records are skipped over by the call chain engine *except* for - * their flags member. - */ - - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], - &isNew); - } - - if (isNew) { - mPtr = ckalloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & PUBLIC_METHOD) { - mPtr->flags &= ~PUBLIC_METHOD; - changed = 1; - } - } - - /* - * Bump the right epoch if we actually changed anything. - */ - - if (changed) { - if (isInstanceUnexport) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, clsPtr); - } - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- - * How to install a constructor or destructor into a class; API to call - * from C. - * - * ---------------------------------------------------------------------- - */ - -void -Tcl_ClassSetConstructor( - Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) -{ - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->constructorPtr) { - TclOODelMethodRef(clsPtr->constructorPtr); - clsPtr->constructorPtr = (Method *) method; - - /* - * Remember to invalidate the cached constructor chain for this class. - * [Bug 2531577] - */ - - if (clsPtr->constructorChainPtr) { - TclOODeleteChain(clsPtr->constructorChainPtr); - clsPtr->constructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); - } -} - -void -Tcl_ClassSetDestructor( - Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) -{ - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->destructorPtr) { - TclOODelMethodRef(clsPtr->destructorPtr); - clsPtr->destructorPtr = (Method *) method; - if (clsPtr->destructorChainPtr) { - TclOODeleteChain(clsPtr->destructorChainPtr); - clsPtr->destructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); - } -} - -/* - * ---------------------------------------------------------------------- - * - * TclOODefineSlots -- - * Create the "::oo::Slot" class and its standard instances. Class - * definition is empty at the stage (added by scripting). - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineSlots( - Foundation *fPtr) -{ - const struct DeclaredSlot *slotInfoPtr; - Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); - Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); - Class *slotCls; - - slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) - fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; - if (slotCls == NULL) { - return TCL_ERROR; - } - Tcl_IncrRefCount(getName); - Tcl_IncrRefCount(setName); - for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { - Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); - - if (slotObject == NULL) { - continue; - } - Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, - &slotInfoPtr->getterType, NULL); - Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, - &slotInfoPtr->setterType, NULL); - } - Tcl_DecrRefCount(getName); - Tcl_DecrRefCount(setName); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassFilterGet, ClassFilterSet -- - * Implementation of the "filter" slot accessors of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ClassFilterGet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *filterObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - resultObj = Tcl_NewObj(); - FOREACH(filterObj, oPtr->classPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassFilterSet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; - Tcl_Obj **filterv; - - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, - &filterv) != TCL_OK) { - return TCL_ERROR; - } - - TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassMixinGet, ClassMixinSet -- - * Implementation of the "mixin" slot accessors of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ClassMixinGet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - Class *mixinPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - 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", NULL); - return TCL_ERROR; - } - - resultObj = Tcl_NewObj(); - FOREACH(mixinPtr, oPtr->classPtr->mixins) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - -} - -static int -ClassMixinSet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc, i; - Tcl_Obj **mixinv; - Class **mixins; - - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "mixinList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, - &mixinv) != TCL_OK) { - return TCL_ERROR; - } - - mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); - - for (i=0 ; i<mixinc ; i++) { - mixins[i] = GetClassInOuterContext(interp, mixinv[i], - "may only mix in classes"); - if (mixins[i] == NULL) { - goto freeAndError; - } - if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); - goto freeAndError; - } - } - - TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); - TclStackFree(interp, mixins); - return TCL_OK; - - freeAndError: - TclStackFree(interp, mixins); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * - * ClassSuperGet, ClassSuperSet -- - * Implementation of the "superclass" slot accessors of the "oo::define" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ClassSuperGet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - Class *superPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - - resultObj = Tcl_NewObj(); - FOREACH(superPtr, oPtr->classPtr->superclasses) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, superPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassSuperSet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int superc, i, j; - Tcl_Obj **superv; - Class **superclasses, *superPtr; - - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "superclassList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", 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", NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(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 = ckrealloc(superclasses, sizeof(Class *)); - superclasses[0] = oPtr->fPtr->objectCls; - superc = 1; - if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { - superclasses[0] = oPtr->fPtr->classCls; - } - } 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",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", NULL); - failedAfterAlloc: - ckfree((char *) superclasses); - return TCL_ERROR; - } - } - } - - /* - * 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); - } - ckfree((char *) 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( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; - 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", NULL); - return TCL_ERROR; - } - - resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ClassVarsSet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc; - Tcl_Obj **varv, *variableObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - - if (oPtr == NULL) { - return TCL_ERROR; - } else if (!oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - for (i=0 ; i<varc ; i++) { - const char *varName = Tcl_GetString(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", 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", NULL); - return TCL_ERROR; - } - } - - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->classPtr->variables.list); - } else if (i) { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - - oPtr->classPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->classPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->classPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); - } - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectFilterGet, ObjectFilterSet -- - * Implementation of the "filter" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjFilterGet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *filterObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - resultObj = Tcl_NewObj(); - FOREACH(filterObj, oPtr->filters) { - Tcl_ListObjAppendElement(NULL, resultObj, filterObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjFilterSet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int filterc; - Tcl_Obj **filterv; - - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "filterList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &filterc, - &filterv) != TCL_OK) { - return TCL_ERROR; - } - - TclOOObjectSetFilters(oPtr, filterc, filterv); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectMixinGet, ObjectMixinSet -- - * Implementation of the "mixin" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjMixinGet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj; - Class *mixinPtr; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - resultObj = Tcl_NewObj(); - FOREACH(mixinPtr, oPtr->mixins) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjMixinSet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int mixinc; - Tcl_Obj **mixinv; - Class **mixins; - int i; - - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "mixinList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, - &mixinv) != TCL_OK) { - return TCL_ERROR; - } - - mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); - - for (i=0 ; i<mixinc ; i++) { - mixins[i] = GetClassInOuterContext(interp, mixinv[i], - "may only mix in classes"); - if (mixins[i] == NULL) { - TclStackFree(interp, mixins); - return TCL_ERROR; - } - } - - TclOOObjectSetMixins(oPtr, mixinc, mixins); - TclStackFree(interp, mixins); - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * - * ObjectVarsGet, ObjectVarsSet -- - * Implementation of the "variable" slot accessors of the "oo::objdefine" - * command. - * - * ---------------------------------------------------------------------- - */ - -static int -ObjVarsGet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; - int i; - - if (Tcl_ObjectContextSkippedArgs(context) != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - - resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -static int -ObjVarsSet( - ClientData clientData, - Tcl_Interp *interp, - Tcl_ObjectContext context, - int objc, - Tcl_Obj *const *objv) -{ - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - int varc, i; - Tcl_Obj **varv, *variableObj; - - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "variableList"); - return TCL_ERROR; - } else if (oPtr == NULL) { - return TCL_ERROR; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &varc, - &varv) != TCL_OK) { - return TCL_ERROR; - } - - for (i=0 ; i<varc ; i++) { - const char *varName = Tcl_GetString(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", 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", NULL); - return TCL_ERROR; - } - } - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - - FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->variables.list); - } else if (i) { - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - oPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); - } - return TCL_OK; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |