diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 2001 |
1 files changed, 0 insertions, 2001 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c deleted file mode 100644 index 72732da..0000000 --- a/generic/tclOODefineCmds.c +++ /dev/null @@ -1,2001 +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-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: - */ |