diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 2001 |
1 files changed, 2001 insertions, 0 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c new file mode 100644 index 0000000..72732da --- /dev/null +++ b/generic/tclOODefineCmds.c @@ -0,0 +1,2001 @@ +/* + * 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-2008 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" + +/* + * 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 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); + +/* + * ---------------------------------------------------------------------- + * + * 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_AppendResult(interp, "method ", TclGetString(fromPtr), + " does not exist", NULL); + 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_AppendResult(interp, "cannot rename method to itself", + NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL); + return TCL_ERROR; + } else if (!isNew) { + renameToExisting: + Tcl_AppendResult(interp, "method called ", + TclGetString(toPtr), " already exists", NULL); + 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_AppendResult(interp, "bad call of unknown handler", NULL); + 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_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL); + 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_AppendResult(interp, + "cannot process definitions; support namespace deleted", + NULL); + 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; + + if ((iPtr->varFramePtr == NULL) + || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { + Tcl_AppendResult(interp, "this command may only be called from within" + " the context of an ::oo::define or ::oo::objdefine command", + NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return NULL; + } + return (Tcl_Object) iPtr->varFramePtr->clientData; +} + +/* + * ---------------------------------------------------------------------- + * + * 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_AppendResult(interp, errMsg, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(className), NULL); + return NULL; + } + return oPtr->classPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * 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_AppendResult(interp, TclGetString(objv[1]), + " does not refer to a class", NULL); + 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) { + result = TclEvalObjEx(interp, objv[2], 0, + ((Interp *)interp)->cmdFramePtr, 2); + + if (result == TCL_ERROR) { + int length; + const char *objName = Tcl_GetStringFromObj(objv[1], &length); + int limit = 60; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in definition script for object \"%.*s%s\" line %d)", + (overflow ? limit : length), objName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + } + } 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) { + result = TclEvalObjEx(interp, objv[2], 0, + ((Interp *)interp)->cmdFramePtr, 2); + + if (result == TCL_ERROR) { + int length; + const char *objName = Tcl_GetStringFromObj(objv[1], &length); + int limit = 60; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in definition script for object \"%.*s%s\" line %d)", + (overflow ? limit : length), objName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + } + } 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) { + result = TclEvalObjEx(interp, objv[1], 0, + ((Interp *)interp)->cmdFramePtr, 2); + + if (result == TCL_ERROR) { + int length; + const char *objName = Tcl_GetStringFromObj( + TclOOObjectName(interp, oPtr), &length); + int limit = 60; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in definition script for object \"%.*s%s\" line %d)", + (overflow ? limit : length), objName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + } + } 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_AppendResult(interp, + "may not modify the class of the root object class", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + if (oPtr->flags & ROOT_CLASS) { + Tcl_AppendResult(interp, + "may not modify the class of the class of classes", NULL); + 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_AppendResult(interp, "may not change a ", + (oPtr->classPtr==NULL ? "non-" : ""), "class object into a ", + (oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL); + 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_AppendResult(interp, "attempt to misuse API", NULL); + 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_AppendResult(interp, "attempt to misuse API", NULL); + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineFilterObjCmd -- + * Implementation of the "filter" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineFilterObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceFilter = (clientData != NULL); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceFilter && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + if (!isInstanceFilter) { + TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1); + } else { + TclOOObjectSetFilters(oPtr, objc-1, objv+1); + } + 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_AppendResult(interp, "attempt to misuse API", NULL); + 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_AppendResult(interp, "attempt to misuse API", NULL); + 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_AppendResult(interp, "attempt to misuse API", NULL); + 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_AppendResult(interp, "may not mix a class into itself", NULL); + 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_AppendResult(interp, "attempt to misuse API", NULL); + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineSuperclassObjCmd -- + * Implementation of the "superclass" subcommand of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineSuperclassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr; + Class **superclasses, *superPtr; + int i, j; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?"); + return TCL_ERROR; + } + + /* + * Get the class to operate on. + */ + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_AppendResult(interp, "only classes may have superclasses defined", + NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "OBJECT_NOT_CLASS", NULL); + return TCL_ERROR; + } + if (oPtr->flags & ROOT_OBJECT) { + Tcl_AppendResult(interp, + "may not modify the superclass of the root object", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + /* + * Allocate some working space. + */ + + superclasses = ckalloc(sizeof(Class *) * (objc-1)); + + /* + * Parse the arguments to get the class to use as superclasses. + */ + + for (i=0 ; i<objc-1 ; i++) { + Class *clsPtr = GetClassInOuterContext(interp, objv[i+1], + "only a class can be a superclass"); + + if (clsPtr == NULL) { + goto failedAfterAlloc; + } + for (j=0 ; j<i ; j++) { + if (superclasses[j] == clsPtr) { + Tcl_AppendResult(interp, + "class should only be a direct superclass once",NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL); + goto failedAfterAlloc; + } + } + if (TclOOIsReachable(oPtr->classPtr, clsPtr)) { + Tcl_AppendResult(interp, + "attempt to form circular dependency graph", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); + failedAfterAlloc: + ckfree(superclasses); + return TCL_ERROR; + } + superclasses[i] = clsPtr; + } + + /* + * 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(oPtr->classPtr->superclasses.list); + } + oPtr->classPtr->superclasses.list = superclasses; + oPtr->classPtr->superclasses.num = objc-1; + FOREACH(superPtr, oPtr->classPtr->superclasses) { + TclOOAddToSubclasses(oPtr->classPtr, superPtr); + } + 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_AppendResult(interp, "attempt to misuse API", NULL); + 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; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineVariablesObjCmd -- + * Implementation of the "variable" subcommand of the "oo::define" and + * "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineVariablesObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstanceVars = (clientData != NULL); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *variableObj; + int i; + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!isInstanceVars && !oPtr->classPtr) { + Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + for (i=1 ; i<objc ; i++) { + const char *varName = Tcl_GetString(objv[i]); + + if (strstr(varName, "::") != NULL) { + Tcl_AppendResult(interp, "invalid declared variable name \"", + varName, "\": must not contain namespace separators", + NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; + } + if (Tcl_StringMatch(varName, "*(*)")) { + Tcl_AppendResult(interp, "invalid declared variable name \"", + varName, "\": must not refer to an array element", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; + } + } + for (i=1 ; i<objc ; i++) { + Tcl_IncrRefCount(objv[i]); + } + + if (!isInstanceVars) { + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_DecrRefCount(variableObj); + } + if (i != objc-1) { + if (objc == 1) { + ckfree(oPtr->classPtr->variables.list); + } else if (i) { + oPtr->classPtr->variables.list = + ckrealloc(oPtr->classPtr->variables.list, + sizeof(Tcl_Obj *) * (objc-1)); + } else { + oPtr->classPtr->variables.list = + ckalloc(sizeof(Tcl_Obj *) * (objc-1)); + } + } + if (objc > 1) { + memcpy(oPtr->classPtr->variables.list, objv+1, + sizeof(Tcl_Obj *) * (objc-1)); + } + oPtr->classPtr->variables.num = objc-1; + } else { + FOREACH(variableObj, oPtr->variables) { + Tcl_DecrRefCount(variableObj); + } + if (i != objc-1) { + if (objc == 1) { + ckfree(oPtr->variables.list); + } else if (i) { + oPtr->variables.list = ckrealloc(oPtr->variables.list, + sizeof(Tcl_Obj *) * (objc-1)); + } else { + oPtr->variables.list = + ckalloc(sizeof(Tcl_Obj *) * (objc-1)); + } + } + if (objc > 1) { + memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1)); + } + oPtr->variables.num = objc-1; + } + return TCL_OK; +} + +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); + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |