diff options
Diffstat (limited to 'generic/tclOODefineCmds.c')
| -rw-r--r-- | generic/tclOODefineCmds.c | 1309 |
1 files changed, 1006 insertions, 303 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 1cf0786..bacab38 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,12 +4,10 @@ * 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 + * Copyright (c) 2006-2012 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. - * - * RCS: @(#) $Id: tclOODefineCmds.c,v 1.13 2010/03/05 11:36:19 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -19,12 +17,38 @@ #include "tclOOInt.h" /* + * The maximum length of fully-qualified object name to use in an errorinfo + * message. Longer than this will be curtailed. + */ + +#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30 + +/* + * Some things that make it easier to declare a slot. + */ + +struct DeclaredSlot { + const char *name; + const Tcl_MethodType getterType; + const Tcl_MethodType setterType; +}; + +#define SLOT(name,getter,setter) \ + {"::oo::" name, \ + {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ + getter, NULL, NULL}, \ + {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + setter, NULL, NULL}} + +/* * Forward declarations. */ static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr); +static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, + Tcl_Obj *savedNameObj, const char *typeOfSubject); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); static inline int InitDefineContext(Tcl_Interp *interp, @@ -34,6 +58,63 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); +static int ClassFilterGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassFilterSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassMixinGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassMixinSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassSuperGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassSuperSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassVarsGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ClassVarsSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjFilterGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjFilterSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjMixinGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjMixinSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjVarsGet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int ObjVarsSet(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); + +/* + * Now define the slots used in declarations. + */ + +static const struct DeclaredSlot slots[] = { + SLOT("define::filter", ClassFilterGet, ClassFilterSet), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet), + SLOT("define::variable", ClassVarsGet, ClassVarsSet), + SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), + SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} +}; /* * ---------------------------------------------------------------------- @@ -131,7 +212,7 @@ TclOOObjectSetFilters( * No list of filters was supplied, so we're deleting filters. */ - ckfree((char *) oPtr->filters.list); + ckfree(oPtr->filters.list); oPtr->filters.list = NULL; oPtr->filters.num = 0; RecomputeClassCacheFlag(oPtr); @@ -144,10 +225,9 @@ TclOOObjectSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (oPtr->filters.num == 0) { - filtersList = (Tcl_Obj **) ckalloc(size); + filtersList = ckalloc(size); } else { - filtersList = (Tcl_Obj **) - ckrealloc((char *) oPtr->filters.list, size); + filtersList = ckrealloc(oPtr->filters.list, size); } for (i=0 ; i<numFilters ; i++) { filtersList[i] = filters[i]; @@ -191,7 +271,7 @@ TclOOClassSetFilters( * No list of filters was supplied, so we're deleting filters. */ - ckfree((char *) classPtr->filters.list); + ckfree(classPtr->filters.list); classPtr->filters.list = NULL; classPtr->filters.num = 0; } else { @@ -203,10 +283,9 @@ TclOOClassSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (classPtr->filters.num == 0) { - filtersList = (Tcl_Obj **) ckalloc(size); + filtersList = ckalloc(size); } else { - filtersList = (Tcl_Obj **) - ckrealloc((char *) classPtr->filters.list, size); + filtersList = ckrealloc(classPtr->filters.list, size); } for (i=0 ; i<numFilters ; i++) { filtersList[i] = filters[i]; @@ -246,7 +325,7 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); } - ckfree((char *) oPtr->mixins.list); + ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; } RecomputeClassCacheFlag(oPtr); @@ -257,12 +336,10 @@ TclOOObjectSetMixins( TclOORemoveFromInstances(oPtr, mixinPtr); } } - oPtr->mixins.list = (Class **) - ckrealloc((char *) oPtr->mixins.list, + oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); } else { - oPtr->mixins.list = (Class **) - ckalloc(sizeof(Class *) * numMixins); + oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); oPtr->flags &= ~USE_CLASS_CACHE; } oPtr->mixins.num = numMixins; @@ -300,7 +377,7 @@ TclOOClassSetMixins( FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); } - ckfree((char *) classPtr->mixins.list); + ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; } } else { @@ -308,12 +385,10 @@ TclOOClassSetMixins( FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); } - classPtr->mixins.list = (Class **) - ckrealloc((char *) classPtr->mixins.list, + classPtr->mixins.list = ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); } else { - classPtr->mixins.list = (Class **) - ckalloc(sizeof(Class *) * numMixins); + classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); } classPtr->mixins.num = numMixins; memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); @@ -348,8 +423,10 @@ RenameDeleteMethod( if (!useClass) { if (!oPtr->methodsPtr) { noSuchMethod: - Tcl_AppendResult(interp, "method ", TclGetString(fromPtr), - " does not exist", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method %s does not exist", TclGetString(fromPtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(fromPtr), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr); @@ -361,13 +438,16 @@ RenameDeleteMethod( &isNew); if (hPtr == newHPtr) { renameToSelf: - Tcl_AppendResult(interp, "cannot rename method to itself", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot rename method to itself", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL); return TCL_ERROR; } else if (!isNew) { renameToExisting: - Tcl_AppendResult(interp, "method called ", - TclGetString(toPtr), " already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "method called %s already exists", + TclGetString(toPtr))); + Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL); return TCL_ERROR; } } @@ -434,7 +514,9 @@ TclOOUnknownDefinition( const char *soughtStr, *matchedStr = NULL; if (objc < 2) { - Tcl_AppendResult(interp, "bad call of unknown handler", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad call of unknown handler", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL); return TCL_ERROR; } if (TclOOGetDefineCmdContext(interp) == NULL) { @@ -478,7 +560,9 @@ TclOOUnknownDefinition( } noMatch: - Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", soughtStr)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL); return TCL_ERROR; } @@ -565,9 +649,10 @@ InitDefineContext( int result; if (namespacePtr == NULL) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot process definitions; support namespace deleted", - NULL); + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -600,15 +685,25 @@ TclOOGetDefineCmdContext( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; + Tcl_Object object; 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_SetObjResult(interp, Tcl_NewStringObj( + "this command may only be called from within the context of" + " an ::oo::define or ::oo::objdefine command", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return NULL; + } + object = iPtr->varFramePtr->clientData; + if (Tcl_ObjectDeleted(object)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "this command cannot be called when the object has been" + " deleted", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } - return (Tcl_Object) iPtr->varFramePtr->clientData; + return object; } /* @@ -645,7 +740,9 @@ GetClassInOuterContext( return NULL; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, errMsg, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(className), NULL); return NULL; } return oPtr->classPtr; @@ -654,6 +751,44 @@ GetClassInOuterContext( /* * ---------------------------------------------------------------------- * + * GenerateErrorInfo -- + * Factored out code to generate part of the error trace messages. + * + * ---------------------------------------------------------------------- + */ + +static void +GenerateErrorInfo( + Tcl_Interp *interp, /* Where to store the error info trace. */ + Object *oPtr, /* What object (or class) was being configured + * when the error occurred? */ + Tcl_Obj *savedNameObj, /* Name of object saved from before script was + * evaluated, which is needed if the object + * goes away part way through execution. OTOH, + * if the object isn't deleted then its + * current name (post-execution) has to be + * used. This matters, because the object + * could have been renamed... */ + const char *typeOfSubject) /* Part of the message, saying whether it was + * an object, class or class-as-object that + * was being configured. */ +{ + int length; + Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) + ? savedNameObj : TclOOObjectName(interp, oPtr); + const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in definition script for %s \"%.*s%s\" line %d)", + typeOfSubject, (overflow ? limit : length), objName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the @@ -685,8 +820,10 @@ TclOODefineObjCmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, TclGetString(objv[1]), - " does not refer to a class", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s does not refer to a class",TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[1]), NULL); return TCL_ERROR; } @@ -701,20 +838,15 @@ TclOODefineObjCmd( AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - 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))); + GenerateErrorInfo(interp, oPtr, objNameObj, "class"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -820,20 +952,15 @@ TclOOObjDefObjCmd( AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - 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))); + GenerateErrorInfo(interp, oPtr, objNameObj, "object"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -939,21 +1066,15 @@ TclOODefineSelfObjCmd( AddRef(oPtr); if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - 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))); + GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -1044,13 +1165,15 @@ TclOODefineClassObjCmd( return TCL_ERROR; } if (oPtr->flags & ROOT_OBJECT) { - Tcl_AppendResult(interp, - "may not modify the class of the root object class", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the root object class", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } if (oPtr->flags & ROOT_CLASS) { - Tcl_AppendResult(interp, - "may not modify the class of the class of classes", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the class of the class of classes", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1075,9 +1198,11 @@ TclOODefineClassObjCmd( */ 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_SetObjResult(interp, Tcl_ObjPrintf( + "may not change a %sclass object into a %sclass object", + (oPtr->classPtr==NULL ? "non-" : ""), + (oPtr->classPtr==NULL ? "" : "non-"))); + Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); return TCL_ERROR; } @@ -1197,7 +1322,9 @@ TclOODefineDeleteMethodObjCmd( return TCL_ERROR; } if (!isInstanceDeleteMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1319,7 +1446,9 @@ TclOODefineExportObjCmd( } clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1335,8 +1464,7 @@ TclOODefineExportObjCmd( if (isInstanceExport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } @@ -1348,7 +1476,7 @@ TclOODefineExportObjCmd( } if (isNew) { - mPtr = (Method *) ckalloc(sizeof(Method)); + mPtr = ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; @@ -1380,42 +1508,6 @@ TclOODefineExportObjCmd( /* * ---------------------------------------------------------------------- * - * 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); - 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. @@ -1446,7 +1538,9 @@ TclOODefineForwardObjCmd( return TCL_ERROR; } if (!isInstanceForward && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") @@ -1502,7 +1596,9 @@ TclOODefineMethodObjCmd( return TCL_ERROR; } if (!isInstanceMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") @@ -1552,7 +1648,9 @@ TclOODefineMixinObjCmd( return TCL_ERROR; } if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); @@ -1565,7 +1663,9 @@ TclOODefineMixinObjCmd( goto freeAndError; } if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_AppendResult(interp, "may not mix a class into itself", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not mix a class into itself", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } mixins[i-1] = clsPtr; @@ -1615,7 +1715,9 @@ TclOODefineRenameMethodObjCmd( return TCL_ERROR; } if (!isInstanceRenameMethod && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -1642,45 +1744,457 @@ TclOODefineRenameMethodObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineSuperclassObjCmd -- - * Implementation of the "superclass" subcommand of the "oo::define" - * command. + * TclOODefineUnexportObjCmd -- + * Implementation of the "unexport" subcommand of the "oo::define" and + * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int -TclOODefineSuperclassObjCmd( +TclOODefineUnexportObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { + int isInstanceUnexport = (clientData != NULL); Object *oPtr; - Class **superclasses, *superPtr; - int i, j; + Method *mPtr; + Tcl_HashEntry *hPtr; + Class *clsPtr; + int i, isNew, changed = 0; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + clsPtr = oPtr->classPtr; + if (!isInstanceUnexport && !clsPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + for (i=1 ; i<objc ; i++) { + /* + * Unexporting is done by removing the PUBLIC_METHOD flag from the + * method record. If there is no such method in this object or class + * (i.e. the method comes from something inherited from or that we're + * an instance of) then we put in a blank record without that flag; + * such records are skipped over by the call chain engine *except* for + * their flags member. + */ + + if (isInstanceUnexport) { + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], + &isNew); + } else { + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], + &isNew); + } + + if (isNew) { + mPtr = ckalloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = objv[i]; + Tcl_IncrRefCount(objv[i]); + Tcl_SetHashValue(hPtr, mPtr); + } else { + mPtr = Tcl_GetHashValue(hPtr); + } + if (isNew || mPtr->flags & PUBLIC_METHOD) { + mPtr->flags &= ~PUBLIC_METHOD; + changed = 1; + } + } + /* - * Get the class to operate on. + * Bump the right epoch if we actually changed anything. */ - oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (changed) { + if (isInstanceUnexport) { + oPtr->epoch++; + } else { + BumpGlobalEpoch(interp, clsPtr); + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * How to install a constructor or destructor into a class; API to call + * from C. + * + * ---------------------------------------------------------------------- + */ + +void +Tcl_ClassSetConstructor( + Tcl_Interp *interp, + Tcl_Class clazz, + Tcl_Method method) +{ + Class *clsPtr = (Class *) clazz; + + if (method != (Tcl_Method) clsPtr->constructorPtr) { + TclOODelMethodRef(clsPtr->constructorPtr); + clsPtr->constructorPtr = (Method *) method; + + /* + * Remember to invalidate the cached constructor chain for this class. + * [Bug 2531577] + */ + + if (clsPtr->constructorChainPtr) { + TclOODeleteChain(clsPtr->constructorChainPtr); + clsPtr->constructorChainPtr = NULL; + } + BumpGlobalEpoch(interp, clsPtr); + } +} + +void +Tcl_ClassSetDestructor( + Tcl_Interp *interp, + Tcl_Class clazz, + Tcl_Method method) +{ + Class *clsPtr = (Class *) clazz; + + if (method != (Tcl_Method) clsPtr->destructorPtr) { + TclOODelMethodRef(clsPtr->destructorPtr); + clsPtr->destructorPtr = (Method *) method; + if (clsPtr->destructorChainPtr) { + TclOODeleteChain(clsPtr->destructorChainPtr); + clsPtr->destructorChainPtr = NULL; + } + BumpGlobalEpoch(interp, clsPtr); + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineSlots -- + * Create the "::oo::Slot" class and its standard instances. Class + * definition is empty at the stage (added by scripting). + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineSlots( + Foundation *fPtr) +{ + const struct DeclaredSlot *slotInfoPtr; + Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); + Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); + Class *slotCls; + + slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) + fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; + if (slotCls == NULL) { + return TCL_ERROR; + } + Tcl_IncrRefCount(getName); + Tcl_IncrRefCount(setName); + for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { + Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, + (Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0); + + if (slotObject == NULL) { + continue; + } + Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, + &slotInfoPtr->getterType, NULL); + Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, + &slotInfoPtr->setterType, NULL); + } + Tcl_DecrRefCount(getName); + Tcl_DecrRefCount(setName); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassFilterGet, ClassFilterSet -- + * Implementation of the "filter" slot accessors of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassFilterGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *filterObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } if (oPtr == NULL) { return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; } - if (oPtr->classPtr == NULL) { - Tcl_AppendResult(interp, "only classes may have superclasses defined", + + resultObj = Tcl_NewObj(); + FOREACH(filterObj, oPtr->classPtr->filters) { + Tcl_ListObjAppendElement(NULL, resultObj, filterObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassFilterSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int filterc; + Tcl_Obj **filterv; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + &filterv) != TCL_OK) { + return TCL_ERROR; + } + + TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassMixinGet, ClassMixinSet -- + * Implementation of the "mixin" slot accessors of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassMixinGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj; + Class *mixinPtr; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; } - if (oPtr->flags & ROOT_OBJECT) { - Tcl_AppendResult(interp, - "may not modify the superclass of the root object", NULL); + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(mixinPtr, oPtr->classPtr->mixins) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, mixinPtr->thisPtr)); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + +} + +static int +ClassMixinSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int mixinc, i; + Tcl_Obj **mixinv; + Class **mixins; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "mixinList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + &mixinv) != TCL_OK) { + return TCL_ERROR; + } + + mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + + for (i=0 ; i<mixinc ; i++) { + mixins[i] = GetClassInOuterContext(interp, mixinv[i], + "may only mix in classes"); + if (mixins[i] == NULL) { + goto freeAndError; + } + if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not mix a class into itself", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); + goto freeAndError; + } + } + + TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); + TclStackFree(interp, mixins); + return TCL_OK; + + freeAndError: + TclStackFree(interp, mixins); + return TCL_ERROR; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassSuperGet, ClassSuperSet -- + * Implementation of the "superclass" slot accessors of the "oo::define" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ClassSuperGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj; + Class *superPtr; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(superPtr, oPtr->classPtr->superclasses) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, superPtr->thisPtr)); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassSuperSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int superc, i, j; + Tcl_Obj **superv; + Class **superclasses, *superPtr; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "superclassList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the superclass of the root object", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &superc, + &superv) != TCL_OK) { return TCL_ERROR; } @@ -1688,34 +2202,34 @@ TclOODefineSuperclassObjCmd( * Allocate some working space. */ - superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1)); + superclasses = (Class **) ckalloc(sizeof(Class *) * superc); /* * 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], + for (i=0 ; i<superc ; i++) { + superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); - - if (clsPtr == NULL) { + if (superclasses[i] == 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); + if (superclasses[j] == superclasses[i]) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "class should only be a direct superclass once", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL); goto failedAfterAlloc; } } - if (TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_AppendResult(interp, - "attempt to form circular dependency graph", NULL); + if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to form circular dependency graph", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: ckfree((char *) superclasses); return TCL_ERROR; } - superclasses[i] = clsPtr; } /* @@ -1732,7 +2246,7 @@ TclOODefineSuperclassObjCmd( ckfree((char *) oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; - oPtr->classPtr->superclasses.num = objc-1; + oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); } @@ -1744,92 +2258,141 @@ TclOODefineSuperclassObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineUnexportObjCmd -- - * Implementation of the "unexport" subcommand of the "oo::define" and - * "oo::objdefine" commands. + * ClassVarsGet, ClassVarsSet -- + * Implementation of the "variable" slot accessors of the "oo::define" + * command. * * ---------------------------------------------------------------------- */ -int -TclOODefineUnexportObjCmd( +static int +ClassVarsGet( ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { - int isInstanceUnexport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *variableObj; + int i; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); return TCL_ERROR; } - - oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; } - clsPtr = oPtr->classPtr; - if (!isInstanceUnexport && !clsPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + + resultObj = Tcl_NewObj(); + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassVarsSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc; + Tcl_Obj **varv, *variableObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); return TCL_ERROR; } + objv += Tcl_ObjectContextSkippedArgs(context); - 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 (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], - &isNew); + for (i=0 ; i<varc ; i++) { + const char *varName = Tcl_GetString(varv[i]); + + if (strstr(varName, "::") != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; } + if (Tcl_StringMatch(varName, "*(*)")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; + } + } - if (isNew) { - mPtr = (Method *) ckalloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_DecrRefCount(variableObj); + } + if (i != varc) { + if (varc == 0) { + ckfree((char *) oPtr->classPtr->variables.list); + } else if (i) { + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->classPtr->variables.list, + sizeof(Tcl_Obj *) * varc); } else { - mPtr = Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & PUBLIC_METHOD) { - mPtr->flags &= ~PUBLIC_METHOD; - changed = 1; + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * varc); } } - /* - * Bump the right epoch if we actually changed anything. - */ + oPtr->classPtr->variables.num = 0; + if (varc > 0) { + int created, n; + Tcl_HashTable uniqueTable; - if (changed) { - if (isInstanceUnexport) { - oPtr->epoch++; - } else { - BumpGlobalEpoch(interp, clsPtr); + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->classPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } } + oPtr->classPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->classPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->classPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); } return TCL_OK; } @@ -1837,139 +2400,279 @@ TclOODefineUnexportObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineVariablesObjCmd -- - * Implementation of the "variable" subcommand of the "oo::define" and - * "oo::objdefine" commands. + * ObjectFilterGet, ObjectFilterSet -- + * Implementation of the "filter" slot accessors of the "oo::objdefine" + * command. * * ---------------------------------------------------------------------- */ -int -TclOODefineVariablesObjCmd( +static int +ObjFilterGet( ClientData clientData, Tcl_Interp *interp, + Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { - int isInstanceVars = (clientData != NULL); Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *variableObj; + Tcl_Obj *resultObj, *filterObj; int i; - if (oPtr == NULL) { + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(filterObj, oPtr->filters) { + Tcl_ListObjAppendElement(NULL, resultObj, filterObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ObjFilterSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int filterc; + Tcl_Obj **filterv; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); + return TCL_ERROR; + } else if (oPtr == NULL) { return TCL_ERROR; } - if (!isInstanceVars && !oPtr->classPtr) { - Tcl_AppendResult(interp, "attempt to misuse API", NULL); + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &filterc, + &filterv) != TCL_OK) { return TCL_ERROR; } - for (i=1 ; i<objc ; i++) { - const char *varName = Tcl_GetString(objv[i]); + TclOOObjectSetFilters(oPtr, filterc, filterv); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ObjectMixinGet, ObjectMixinSet -- + * Implementation of the "mixin" slot accessors of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ - if (strstr(varName, "::") != NULL) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not contain namespace separators", - NULL); - return TCL_ERROR; - } - if (Tcl_StringMatch(varName, "*(*)")) { - Tcl_AppendResult(interp, "invalid declared variable name \"", - varName, "\": must not refer to an array element", NULL); - return TCL_ERROR; - } +static int +ObjMixinGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj; + Class *mixinPtr; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; } - for (i=1 ; i<objc ; i++) { - Tcl_IncrRefCount(objv[i]); + + resultObj = Tcl_NewObj(); + FOREACH(mixinPtr, oPtr->mixins) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, mixinPtr->thisPtr)); } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} - if (!isInstanceVars) { - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != objc-1) { - if (objc == 1) { - ckfree((char *) oPtr->classPtr->variables.list); - } else if (i) { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * (objc-1)); - } else { - oPtr->classPtr->variables.list = (Tcl_Obj **) - 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((char *) oPtr->variables.list); - } else if (i) { - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * (objc-1)); - } else { - oPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * (objc-1)); - } - } - if (objc > 1) { - memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1)); +static int +ObjMixinSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int mixinc; + Tcl_Obj **mixinv; + Class **mixins; + int i; + + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "mixinList"); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &mixinc, + &mixinv) != TCL_OK) { + return TCL_ERROR; + } + + mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); + + for (i=0 ; i<mixinc ; i++) { + mixins[i] = GetClassInOuterContext(interp, mixinv[i], + "may only mix in classes"); + if (mixins[i] == NULL) { + TclStackFree(interp, mixins); + return TCL_ERROR; } - oPtr->variables.num = objc-1; } + + TclOOObjectSetMixins(oPtr, mixinc, mixins); + TclStackFree(interp, mixins); return TCL_OK; } -void -Tcl_ClassSetConstructor( +/* + * ---------------------------------------------------------------------- + * + * ObjectVarsGet, ObjectVarsSet -- + * Implementation of the "variable" slot accessors of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ + +static int +ObjVarsGet( + ClientData clientData, Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) { - Class *clsPtr = (Class *) clazz; - - if (method != (Tcl_Method) clsPtr->constructorPtr) { - TclOODelMethodRef(clsPtr->constructorPtr); - clsPtr->constructorPtr = (Method *) method; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *variableObj; + int i; - /* - * Remember to invalidate the cached constructor chain for this class. - * [Bug 2531577] - */ + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } - if (clsPtr->constructorChainPtr) { - TclOODeleteChain(clsPtr->constructorChainPtr); - clsPtr->constructorChainPtr = NULL; - } - BumpGlobalEpoch(interp, clsPtr); + resultObj = Tcl_NewObj(); + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; } -void -Tcl_ClassSetDestructor( +static int +ObjVarsSet( + ClientData clientData, Tcl_Interp *interp, - Tcl_Class clazz, - Tcl_Method method) + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) { - Class *clsPtr = (Class *) clazz; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc, i; + Tcl_Obj **varv, *variableObj; - if (method != (Tcl_Method) clsPtr->destructorPtr) { - TclOODelMethodRef(clsPtr->destructorPtr); - clsPtr->destructorPtr = (Method *) method; - if (clsPtr->destructorChainPtr) { - TclOODeleteChain(clsPtr->destructorChainPtr); - clsPtr->destructorChainPtr = NULL; + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "variableList"); + return TCL_ERROR; + } else if (oPtr == NULL) { + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } + + for (i=0 ; i<varc ; i++) { + const char *varName = Tcl_GetString(varv[i]); + + if (strstr(varName, "::") != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "contain namespace separators")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; } - BumpGlobalEpoch(interp, clsPtr); + if (Tcl_StringMatch(varName, "*(*)")) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid declared variable name \"%s\": must not %s", + varName, "refer to an array element")); + Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL); + return TCL_ERROR; + } + } + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + + FOREACH(variableObj, oPtr->variables) { + Tcl_DecrRefCount(variableObj); } + if (i != varc) { + if (varc == 0) { + ckfree((char *) oPtr->variables.list); + } else if (i) { + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * varc); + } else { + oPtr->variables.list = (Tcl_Obj **) + ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + oPtr->variables.num = 0; + if (varc > 0) { + int created, n; + Tcl_HashTable uniqueTable; + + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + oPtr->variables.list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + oPtr->variables.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + oPtr->variables.list = (Tcl_Obj **) + ckrealloc((char *) oPtr->variables.list, + sizeof(Tcl_Obj *) * n); + Tcl_DeleteHashTable(&uniqueTable); + } + return TCL_OK; } /* |