From c0eed541eb68702b1c43e3e9fd271ea6a0a6b70e Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Dec 2019 13:24:59 +0000 Subject: Implementation of properties for TclOO --- generic/tclOO.c | 53 +++++- generic/tclOOCall.c | 200 ++++++++++++++++++- generic/tclOODefineCmds.c | 475 +++++++++++++++++++++++++++++++++++++++++----- generic/tclOOInfo.c | 183 +++++++++++++++++- generic/tclOOInt.h | 42 +++- generic/tclOOScript.h | 114 +++++++++++ tools/tclOOScript.tcl | 131 +++++++++++++ 7 files changed, 1139 insertions(+), 59 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index af5ea50..8710a89 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3,7 +3,7 @@ * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2019 by Donal K. Fellows * Copyright (c) 2017 by Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of @@ -323,6 +323,7 @@ InitFoundation( DeletedObjdefNamespace); fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr, DeletedHelpersNamespace); + Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL); fPtr->epoch = 0; fPtr->tsdPtr = tsdPtr; TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); @@ -961,7 +962,7 @@ TclOOReleaseClassContents( Class *clsPtr = oPtr->classPtr, *tmpClsPtr; Method *mPtr; Foundation *fPtr = oPtr->fPtr; - Tcl_Obj *variableObj; + Tcl_Obj *variableObj, *propertyObj; PrivateVariableMapping *privateVariable; /* @@ -1015,6 +1016,29 @@ TclOOReleaseClassContents( } /* + * Squelch the property lists. + */ + + if (clsPtr->properties.allReadableCache) { + Tcl_DecrRefCount(clsPtr->properties.allReadableCache); + } + if (clsPtr->properties.allWritableCache) { + Tcl_DecrRefCount(clsPtr->properties.allWritableCache); + } + if (clsPtr->properties.readable.num) { + FOREACH(propertyObj, clsPtr->properties.readable) { + Tcl_DecrRefCount(propertyObj); + } + ckfree(clsPtr->properties.readable.list); + } + if (clsPtr->properties.writable.num) { + FOREACH(propertyObj, clsPtr->properties.writable) { + Tcl_DecrRefCount(propertyObj); + } + ckfree(clsPtr->properties.writable.list); + } + + /* * Squelch our filter list. */ @@ -1115,7 +1139,7 @@ ObjectNamespaceDeleted( FOREACH_HASH_DECLS; Class *mixinPtr; Method *mPtr; - Tcl_Obj *filterObj, *variableObj; + Tcl_Obj *filterObj, *variableObj, *propertyObj; PrivateVariableMapping *privateVariable; Tcl_Interp *interp = oPtr->fPtr->interp; int i; @@ -1269,6 +1293,29 @@ ObjectNamespaceDeleted( } /* + * Squelch the property lists. + */ + + if (oPtr->properties.allReadableCache) { + Tcl_DecrRefCount(oPtr->properties.allReadableCache); + } + if (oPtr->properties.allWritableCache) { + Tcl_DecrRefCount(oPtr->properties.allWritableCache); + } + if (oPtr->properties.readable.num) { + FOREACH(propertyObj, oPtr->properties.readable) { + Tcl_DecrRefCount(propertyObj); + } + ckfree(oPtr->properties.readable.list); + } + if (oPtr->properties.writable.num) { + FOREACH(propertyObj, oPtr->properties.writable) { + Tcl_DecrRefCount(propertyObj); + } + ckfree(oPtr->properties.writable.list); + } + + /* * Because an object can be a class that is an instance of itself, the * class object's class structure should only be cleaned after most of * the cleanup on the object is done. diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index f3474b6..f647fb7 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -2,9 +2,10 @@ * tclOOCall.c -- * * This file contains the method call chain management code for the - * object-system core. + * object-system core. It also contains everything else that does + * inheritance hierarchy traversal. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2019 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. @@ -2100,6 +2101,201 @@ AddDefinitionNamespaceToChain( definePtr->num++; } +static void +FindClassProps( + Class *clsPtr, + int writable, + Tcl_HashTable *accumulator) +{ + int i, dummy; + Tcl_Obj *propName; + Class *mixin, *sup; + + tailRecurse: + if (writable) { + FOREACH(propName, clsPtr->properties.writable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } else { + FOREACH(propName, clsPtr->properties.readable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } + if (clsPtr->thisPtr->flags & ROOT_OBJECT) { + /* + * We do *not* traverse upwards from the root! + */ + return; + } + FOREACH(mixin, clsPtr->mixins) { + FindClassProps(mixin, writable, accumulator); + } + if (clsPtr->superclasses.num == 1) { + clsPtr = clsPtr->superclasses.list[0]; + goto tailRecurse; + } + FOREACH(sup, clsPtr->superclasses) { + FindClassProps(sup, writable, accumulator); + } +} + +static void +FindObjectProps( + Object *oPtr, + int writable, + Tcl_HashTable *accumulator) +{ + int i, dummy; + Tcl_Obj *propName; + Class *mixin; + + if (writable) { + FOREACH(propName, oPtr->properties.writable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } else { + FOREACH(propName, oPtr->properties.readable) { + Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + } + } + FOREACH(mixin, oPtr->mixins) { + FindClassProps(mixin, writable, accumulator); + } + FindClassProps(oPtr->selfCls, writable, accumulator); +} + +Tcl_Obj * +TclOOGetAllClassProperties( + Class *clsPtr, + int writable, + int *allocated) +{ + Tcl_HashTable hashTable; + FOREACH_HASH_DECLS; + Tcl_Obj *propName, *result; + void *dummy; + + /* + * Look in the cache. + */ + + if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) { + if (writable) { + if (clsPtr->properties.allWritableCache) { + *allocated = 0; + return clsPtr->properties.allWritableCache; + } + } else { + if (clsPtr->properties.allReadableCache) { + *allocated = 0; + return clsPtr->properties.allReadableCache; + } + } + } + + /* + * Gather the information. Unsorted! (Caller will sort.) + */ + + *allocated = 1; + Tcl_InitObjHashTable(&hashTable); + FindClassProps(clsPtr, writable, &hashTable); + result = Tcl_NewObj(); + FOREACH_HASH(propName, dummy, &hashTable) { + Tcl_ListObjAppendElement(NULL, result, propName); + } + Tcl_DeleteHashTable(&hashTable); + + /* + * Cache the information. Also purges the cache. + */ + + if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) { + if (clsPtr->properties.allWritableCache) { + Tcl_DecrRefCount(clsPtr->properties.allWritableCache); + clsPtr->properties.allWritableCache = NULL; + } + if (clsPtr->properties.allReadableCache) { + Tcl_DecrRefCount(clsPtr->properties.allReadableCache); + clsPtr->properties.allReadableCache = NULL; + } + } + clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch; + if (writable) { + clsPtr->properties.allWritableCache = result; + } else { + clsPtr->properties.allReadableCache = result; + } + Tcl_IncrRefCount(result); + return result; +} + +Tcl_Obj * +TclOOGetAllObjectProperties( + Object *oPtr, + int writable, + int *allocated) +{ + Tcl_HashTable hashTable; + FOREACH_HASH_DECLS; + Tcl_Obj *propName, *result; + void *dummy; + + /* + * Look in the cache. + */ + + if (oPtr->properties.epoch == oPtr->fPtr->epoch) { + if (writable) { + if (oPtr->properties.allWritableCache) { + *allocated = 0; + return oPtr->properties.allWritableCache; + } + } else { + if (oPtr->properties.allReadableCache) { + *allocated = 0; + return oPtr->properties.allReadableCache; + } + } + } + + /* + * Gather the information. Unsorted! (Caller will sort.) + */ + + *allocated = 1; + Tcl_InitObjHashTable(&hashTable); + FindObjectProps(oPtr, writable, &hashTable); + result = Tcl_NewObj(); + FOREACH_HASH(propName, dummy, &hashTable) { + Tcl_ListObjAppendElement(NULL, result, propName); + } + Tcl_DeleteHashTable(&hashTable); + + /* + * Cache the information. + */ + + if (oPtr->properties.epoch != oPtr->fPtr->epoch) { + if (oPtr->properties.allWritableCache) { + Tcl_DecrRefCount(oPtr->properties.allWritableCache); + oPtr->properties.allWritableCache = NULL; + } + if (oPtr->properties.allReadableCache) { + Tcl_DecrRefCount(oPtr->properties.allReadableCache); + oPtr->properties.allReadableCache = NULL; + } + } + oPtr->properties.epoch = oPtr->fPtr->epoch; + if (writable) { + oPtr->properties.allWritableCache = result; + } else { + oPtr->properties.allReadableCache = result; + } + Tcl_IncrRefCount(result); + return result; +} + /* * Local Variables: * mode: c diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f259954..7b70c79 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2013 by Donal K. Fellows + * Copyright (c) 2006-2019 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. @@ -78,51 +78,18 @@ 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); -static int ResolveClass(ClientData clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); +static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet; +static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet; +static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet; +static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet; +static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet; +static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet; +static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet; +static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet; +static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet; +static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet; +static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet; +static Tcl_MethodCallProc ResolveClass; /* * Now define the slots used in declarations. @@ -136,6 +103,14 @@ static const struct DeclaredSlot slots[] = { SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), + SLOT("configuresupport::readableproperties", + ClassRPropsGet, ClassRPropsSet, NULL), + SLOT("configuresupport::writableproperties", + ClassWPropsGet, ClassWPropsSet, NULL), + SLOT("configuresupport::objreadableproperties", + ObjRPropsGet, ObjRPropsSet, NULL), + SLOT("configuresupport::objwritableproperties", + ObjWPropsGet, ObjWPropsSet, NULL), {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; @@ -201,13 +176,26 @@ BumpGlobalEpoch( if (classPtr->thisPtr->mixins.num > 0) { classPtr->thisPtr->epoch++; + + /* + * Invalidate the property caches directly. + */ + + if (classPtr->properties.allReadableCache) { + Tcl_DecrRefCount(classPtr->properties.allReadableCache); + classPtr->properties.allReadableCache = NULL; + } + if (classPtr->properties.allWritableCache) { + Tcl_DecrRefCount(classPtr->properties.allWritableCache); + classPtr->properties.allWritableCache = NULL; + } } return; } /* * Either there's no class (?!) or we're reconfiguring something that is - * in use. Force regeneration of call chains. + * in use. Force regeneration of call chains and properties. */ TclOOGetFoundation(interp)->epoch++; @@ -482,6 +470,7 @@ TclOOClassSetMixins( * * ---------------------------------------------------------------------- */ + static inline void InstallStandardVariableMapping( VariableNameList *vnlPtr, @@ -3080,6 +3069,398 @@ ResolveClass( } /* + * ---------------------------------------------------------------------- + * + * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet -- + * + * Implementations of the "readableproperties" slot accessors for classes + * and instances. + * + * ---------------------------------------------------------------------- + */ + +static void +InstallReadableProps( + PropertyStorage *props, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *propObj; + int i, n, created; + Tcl_HashTable uniqueTable; + + if (props->allReadableCache) { + Tcl_DecrRefCount(props->allReadableCache); + props->allReadableCache = NULL; + } + + for (i=0 ; ireadable) { + Tcl_DecrRefCount(propObj); + } + if (i != objc) { + if (objc == 0) { + ckfree(props->readable.list); + } else if (i) { + props->readable.list = ckrealloc(props->readable.list, + sizeof(Tcl_Obj *) * objc); + } else { + props->readable.list = ckalloc(sizeof(Tcl_Obj *) * objc); + } + } + props->readable.num = 0; + if (objc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; ireadable.list[n++] = objv[i]; + } else { + Tcl_DecrRefCount(objv[i]); + } + } + props->readable.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != objc) { + props->readable.list = ckrealloc(props->readable.list, + sizeof(Tcl_Obj *) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +static int +ClassRPropsGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *propNameObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(propNameObj, oPtr->classPtr->properties.readable) { + Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassRPropsSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc; + Tcl_Obj **varv; + + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } + + InstallReadableProps(&oPtr->classPtr->properties, varc, varv); + BumpGlobalEpoch(interp, oPtr->classPtr); + return TCL_OK; +} + +static int +ObjRPropsGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *propNameObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } + if (oPtr == NULL) { + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(propNameObj, oPtr->properties.readable) { + Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ObjRPropsSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc; + Tcl_Obj **varv; + + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "filterList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } + + InstallReadableProps(&oPtr->properties, varc, varv); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet -- + * + * Implementations of the "writableproperties" slot accessors for classes + * and instances. + * + * ---------------------------------------------------------------------- + */ + +static void +InstallWritableProps( + PropertyStorage *props, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *propObj; + int i, n, created; + Tcl_HashTable uniqueTable; + + if (props->allWritableCache) { + Tcl_DecrRefCount(props->allWritableCache); + props->allWritableCache = NULL; + } + + for (i=0 ; iwritable) { + Tcl_DecrRefCount(propObj); + } + if (i != objc) { + if (objc == 0) { + ckfree(props->writable.list); + } else if (i) { + props->writable.list = ckrealloc(props->writable.list, + sizeof(Tcl_Obj *) * objc); + } else { + props->writable.list = ckalloc(sizeof(Tcl_Obj *) * objc); + } + } + props->writable.num = 0; + if (objc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; iwritable.list[n++] = objv[i]; + } else { + Tcl_DecrRefCount(objv[i]); + } + } + props->writable.num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != objc) { + props->writable.list = ckrealloc(props->writable.list, + sizeof(Tcl_Obj *) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +static int +ClassWPropsGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *propNameObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(propNameObj, oPtr->classPtr->properties.writable) { + Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ClassWPropsSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc; + Tcl_Obj **varv; + + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "propertyList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } + + InstallWritableProps(&oPtr->classPtr->properties, varc, varv); + BumpGlobalEpoch(interp, oPtr->classPtr); + return TCL_OK; +} + +static int +ObjWPropsGet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Tcl_Obj *resultObj, *propNameObj; + int i; + + if (Tcl_ObjectContextSkippedArgs(context) != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } + if (oPtr == NULL) { + return TCL_ERROR; + } + + resultObj = Tcl_NewObj(); + FOREACH(propNameObj, oPtr->properties.writable) { + Tcl_ListObjAppendElement(NULL, resultObj, propNameObj); + } + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +static int +ObjWPropsSet( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int varc; + Tcl_Obj **varv; + + if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "propertyList"); + return TCL_ERROR; + } + objv += Tcl_ObjectContextSkippedArgs(context); + + if (oPtr == NULL) { + return TCL_ERROR; + } else if (Tcl_ListObjGetElements(interp, objv[0], &varc, + &varv) != TCL_OK) { + return TCL_ERROR; + } + + InstallWritableProps(&oPtr->properties, varc, varv); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 99918ae..ed44cc8 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo-related [info] * subcommands. * - * Copyright (c) 2006-2011 by Donal K. Fellows + * Copyright (c) 2006-2019 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. @@ -17,6 +17,7 @@ #include "tclOOInt.h" static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void SortPropList(Tcl_Obj *list); static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; @@ -28,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; +static Tcl_ObjCmdProc InfoObjectPropCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassCallCmd; @@ -41,6 +43,7 @@ static Tcl_ObjCmdProc InfoClassInstancesCmd; static Tcl_ObjCmdProc InfoClassMethodsCmd; static Tcl_ObjCmdProc InfoClassMethodTypeCmd; static Tcl_ObjCmdProc InfoClassMixinsCmd; +static Tcl_ObjCmdProc InfoClassPropCmd; static Tcl_ObjCmdProc InfoClassSubsCmd; static Tcl_ObjCmdProc InfoClassSupersCmd; static Tcl_ObjCmdProc InfoClassVariablesCmd; @@ -61,6 +64,7 @@ static const EnsembleImplMap infoObjectCmds[] = { {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, + {"property", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} @@ -82,6 +86,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"property", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, @@ -1714,6 +1719,182 @@ InfoClassCallCmd( } /* + * ---------------------------------------------------------------------- + * + * InfoClassPropCmd, InfoObjectPropCmd -- + * + * Implements [info class property $clsName ?$option...?] and + * [info object property $objName ?$option...?] + * + * ---------------------------------------------------------------------- + */ + +enum PropOpt { + PROP_ALL, PROP_READABLE, PROP_WRITABLE +}; +static const char *const propOptNames[] = { + "-all", "-readable", "-writable", + NULL +}; + +static int +InfoClassPropCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + int i, idx, all = 0, writable = 0, allocated = 0; + Tcl_Obj *result, *propObj; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case PROP_ALL: + all = 1; + break; + case PROP_READABLE: + writable = 0; + break; + case PROP_WRITABLE: + writable = 1; + break; + } + } + + /* + * Get the properties. + */ + + if (all) { + result = TclOOGetAllClassProperties(clsPtr, writable, &allocated); + if (allocated) { + SortPropList(result); + } + } else { + result = Tcl_NewObj(); + if (writable) { + FOREACH(propObj, clsPtr->properties.writable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } else { + FOREACH(propObj, clsPtr->properties.readable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } + SortPropList(result); + } + Tcl_SetObjResult(interp, result); + return TCL_OK; +} + +static int +InfoObjectPropCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + int i, idx, all = 0, writable = 0, allocated = 0; + Tcl_Obj *result, *propObj; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case PROP_ALL: + all = 1; + break; + case PROP_READABLE: + writable = 0; + break; + case PROP_WRITABLE: + writable = 1; + break; + } + } + + /* + * Get the properties. + */ + + if (all) { + result = TclOOGetAllObjectProperties(oPtr, writable, &allocated); + if (allocated) { + SortPropList(result); + } + } else { + result = Tcl_NewObj(); + if (writable) { + FOREACH(propObj, oPtr->properties.writable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } else { + FOREACH(propObj, oPtr->properties.readable) { + Tcl_ListObjAppendElement(NULL, result, propObj); + } + } + SortPropList(result); + } + Tcl_SetObjResult(interp, result); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * SortPropList -- + * Sort a list of names of properties. Simple support function. + * + * ---------------------------------------------------------------------- + */ + +static int +PropNameCompare( + const void *a, + const void *b) +{ + Tcl_Obj *first = *(Tcl_Obj **) a; + Tcl_Obj *second = *(Tcl_Obj **) b; + + return strcmp(Tcl_GetString(first), Tcl_GetString(second)); +} + +static void +SortPropList( + Tcl_Obj *list) +{ + int ec; + Tcl_Obj **ev; + + Tcl_ListObjGetElements(NULL, list, &ec, &ev); + qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ca984d0..e8b8f4a 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -161,6 +161,26 @@ typedef LIST_STATIC(Tcl_Obj *) VariableNameList; typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; /* + * This type is used in various places. + */ + +typedef struct { + LIST_STATIC(Tcl_Obj *) readable; + /* The readable properties slot. */ + LIST_STATIC(Tcl_Obj *) writable; + /* The writable properties slot. */ + Tcl_Obj *allReadableCache; /* The cache of all readable properties + * exposed by this object or class (in its + * stereotypical instancs). Contains a sorted + * unique list if not NULL. */ + Tcl_Obj *allWritableCache; /* The cache of all writable properties + * exposed by this object or class (in its + * stereotypical instances). Contains a sorted + * unique list if not NULL. */ + int epoch; /* The epoch that the caches are valid for. */ +} PropertyStorage; + +/* * Now, the definition of what an object actually is. */ @@ -182,8 +202,8 @@ typedef struct Object { LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ struct Class *classPtr; /* This is non-NULL for all classes, and NULL - * for everything else. It points to the class - * structure. */ + * for everything else. It points to the class + * structure. */ int refCount; /* Number of strong references to this object. * Note that there may be many more weak * references; this mechanism exists to @@ -211,12 +231,15 @@ typedef struct Object { * used inside methods. */ Tcl_Command myclassCommand; /* Reference to this object's class dispatcher * command. */ + PropertyStorage properties; /* Information relating to the lists of + * properties that this object *claims* to + * support. */ } Object; -#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has - * been destroyed */ -#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor script for the - object has began */ +#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has + * been destroyed */ +#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor + * script for the object has began */ #define OO_UNUSED_4 4 /* No longer used. */ #define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of * the class hierarchy and should be treated @@ -319,6 +342,9 @@ typedef struct Class { * namespace is defined but doesn't exist; we * also check at setting time but don't check * between times. */ + PropertyStorage properties; /* Information relating to the lists of + * properties that this class *claims* to + * support. */ } Class; /* @@ -568,6 +594,10 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); +MODULE_SCOPE Tcl_Obj * TclOOGetAllClassProperties(Class *clsPtr, + int writable, int *allocated); +MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr, + int writable, int *allocated); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Object *contextObjPtr, Class *contextClsPtr, diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index a1e4624..c8a79a9 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -248,6 +248,120 @@ static const char *tclOOSetupScript = "\t\tsuperclass class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" +"\tnamespace eval configuresupport {\n" +"\t\tproc property {readslot writeslot args} {\n" +"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n" +"\t\t\t\tset prop [lindex $args $i]\n" +"\t\t\t\tif {[string match \"-*\" $prop]} {\n" +"\t\t\t\t\treturn -code error -errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\"; must not begin with -\"\n" +"\t\t\t\t}\n" +"\t\t\t\tset realprop [string cat \"-\" $prop]\n" +"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n" +"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n" +"\t\t\t\tset kind readwrite\n" +"\t\t\t\twhile {[string match \"-*\" [set next [lindex $args [expr {$i + 1}]]]]} {\n" +"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n" +"\t\t\t\t\tswitch [::tcl::prefix match {-get -kind -set} $next] {\n" +"\t\t\t\t\t\t-get {\n" +"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n" +"\t\t\t\t\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n" +"\t\t\t\t\t\t\t}\n" +"\t\t\t\t\t\t\tset getter $arg\n" +"\t\t\t\t\t\t}\n" +"\t\t\t\t\t\t-set {\n" +"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n" +"\t\t\t\t\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n" +"\t\t\t\t\t\t\t}\n" +"\t\t\t\t\t\t\tset getter $arg\n" +"\t\t\t\t\t\t}\n" +"\t\t\t\t\t\t-kind {\n" +"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n" +"\t\t\t\t\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n" +"\t\t\t\t\t\t\t}\n" +"\t\t\t\t\t\t\tset kind [::tcl::prefix match -message \"kind\" {\n" +"\t\t\t\t\t\t\t\treadable readwrite writable\n" +"\t\t\t\t\t\t\t} $arg]\n" +"\t\t\t\t\t\t}\n" +"\t\t\t\t\t}\n" +"\t\t\t\t}\n" +"\t\t\t\tswitch $kind {\n" +"\t\t\t\t\treadable {\n" +"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list method {} $getter]\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\twritable {\n" +"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list method {value} $setter]\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\treadwrite {\n" +"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list method {} $getter]\n" +"\t\t\t\t\t\tuplevel 1 [list method {value} $setter]\n" +"\t\t\t\t\t}\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t}\n" +"\t\tnamespace eval configurableclass {\n" +"\t\t\tproc property args {\n" +"\t\t\t\ttailcall ::oo::configuresupport::property \\\n" +"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" +"\t\t\t\t\t::oo::configuresupport::writableproperties \\\n" +"\t\t\t\t\t{*}$args\n" +"\t\t\t}\n" +"\t\t\tnamespace path ::oo::define\n" +"\t\t}\n" +"\t\tnamespace eval configurableobject {\n" +"\t\t\tproc property args {\n" +"\t\t\t\ttailcall ::oo::configuresupport::property \\\n" +"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" +"\t\t\t\t\t::oo::configuresupport::objwritableproperties \\\n" +"\t\t\t\t\t{*}$args\n" +"\t\t\t}\n" +"\t\t\tnamespace path ::oo::objdefine\n" +"\t\t}\n" +"\t}\n" +"\tclass create configurable {\n" +"\t\tsuperclass class\n" +"\t\tconstructor {{definitionScript \"\"}} {\n" +"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\t\tnext $definitionScript\n" +"\t\t}\n" +"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" +"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" +"\t}\n" +"\tclass create configuresupport::configurable {\n" +"\t\tprivate method Configure:Match {prop kind} {\n" +"\t\t\tset props [info object property [self] -all $kind]\n" +"\t\t\t::tcl::prefix match -message \"property\" $props $prop\n" +"\t\t}\n" +"\t\tmethod configure args {\n" +"\t\t\tif {[llength $args] == 0} {\n" +"\t\t\t\tset result {}\n" +"\t\t\t\tforeach prop [info object property [self] -all -readable] {\n" +"\t\t\t\t\tdict set result $prop [my ]\n" +"\t\t\t\t}\n" +"\t\t\t\treturn $result\n" +"\t\t\t} elseif {[llength $args] == 1} {\n" +"\t\t\t\tset prop [my Configure:Match [lindex $args 0] -readable]\n" +"\t\t\t\treturn [my ]\n" +"\t\t\t} elseif {[llength $args] % 2 == 0} {\n" +"\t\t\t\tforeach {prop value} $args {\n" +"\t\t\t\t\tset prop [my Configure:Match $prop -writable]\n" +"\t\t\t\t\tmy $value\n" +"\t\t\t\t}\n" +"\t\t\t\treturn\n" +"\t\t\t} else {\n" +"\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t[format \"wrong # args: should be \\\"%s\\\"\" \\\n" +"\t\t\t\t\t\t \"[self] configure \?-option value ...\?\"]\n" +"\t\t\t}\n" +"\t\t}\n" +"\t}\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 5e0145f..8cc9627 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -447,6 +447,137 @@ superclass class unexport create createWithNamespace new } + + # ---------------------------------------------------------------------- + # + # oo::configurable -- + # + # A metaclass that is used to make classes that can be configured. Also + # its supporting classes and namespaces. + # + # ---------------------------------------------------------------------- + + namespace eval configuresupport { + proc property {readslot writeslot args} { + for {set i 0} {$i < [llength $args]} {incr i} { + # Parse the property name + set prop [lindex $args $i] + if {[string match "-*" $prop]} { + return -code error -errorcode {TCLOO PROPERTY_FORMAT} \ + "bad property name \"$prop\"; must not begin with -" + } + set realprop [string cat "-" $prop] + set getter [format {::set [my varname %s]} $prop] + set setter [format {::set [my varname %s] $value} $prop] + set kind readwrite + + # Parse the extra options + while {[string match "-*" [set next [lindex $args [expr {$i + 1}]]]]} { + set arg [lindex $args [incr i 2]] + switch [::tcl::prefix match {-get -kind -set} $next] { + -get { + if {$i >= [llength $args]} { + return -code error -errorcode {TCL WRONGARGS} \ + "missing body to go with -get option" + } + set getter $arg + } + -set { + if {$i >= [llength $args]} { + return -code error -errorcode {TCL WRONGARGS} \ + "missing body to go with -set option" + } + set getter $arg + } + -kind { + if {$i >= [llength $args]} { + return -code error -errorcode {TCL WRONGARGS} \ + "missing kind value to go with -kind option" + } + set kind [::tcl::prefix match -message "kind" { + readable readwrite writable + } $arg] + } + } + } + + # Install the option + switch $kind { + readable { + uplevel 1 [list $readslot -append $realprop] + uplevel 1 [list method {} $getter] + } + writable { + uplevel 1 [list $writeslot -append $realprop] + uplevel 1 [list method {value} $setter] + } + readwrite { + uplevel 1 [list $readslot -append $realprop] + uplevel 1 [list $writeslot -append $realprop] + uplevel 1 [list method {} $getter] + uplevel 1 [list method {value} $setter] + } + } + } + } + namespace eval configurableclass { + proc property args { + tailcall ::oo::configuresupport::property \ + ::oo::configuresupport::readableproperties \ + ::oo::configuresupport::writableproperties \ + {*}$args + } + namespace path ::oo::define + } + namespace eval configurableobject { + proc property args { + tailcall ::oo::configuresupport::property \ + ::oo::configuresupport::objreadableproperties \ + ::oo::configuresupport::objwritableproperties \ + {*}$args + } + namespace path ::oo::objdefine + } + } + + class create configurable { + superclass class + constructor {{definitionScript ""}} { + next {mixin ::oo::configuresupport::configurable} + next $definitionScript + } + definitionnamespace -class configuresupport::configurableclass + definitionnamespace -instance configuresupport::configurableobject + } + + class create configuresupport::configurable { + private method Configure:Match {prop kind} { + set props [info object property [self] -all $kind] + ::tcl::prefix match -message "property" $props $prop + } + method configure args { + if {[llength $args] == 0} { + set result {} + foreach prop [info object property [self] -all -readable] { + dict set result $prop [my ] + } + return $result + } elseif {[llength $args] == 1} { + set prop [my Configure:Match [lindex $args 0] -readable] + return [my ] + } elseif {[llength $args] % 2 == 0} { + foreach {prop value} $args { + set prop [my Configure:Match $prop -writable] + my $value + } + return + } else { + return -code error -errorcode {TCL WRONGARGS} \ + [format "wrong # args: should be \"%s\"" \ + "[self] configure ?-option value ...?"] + } + } + } } # Local Variables: -- cgit v0.12 From 76c3874ad8500c1db1360a8a80ae1f8040f32448 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Dec 2019 21:55:56 +0000 Subject: Starting to do the testing. --- generic/tclOOScript.h | 57 +++++++----- tests/oo.test | 248 +++++++++++++++++++++++++++++++++++++++++++++++++- tools/tclOOScript.tcl | 131 ++++++++++++++++++++------ 3 files changed, 379 insertions(+), 57 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index c8a79a9..b9223ee 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -249,7 +249,7 @@ static const char *tclOOSetupScript = "\t\tunexport create createWithNamespace new\n" "\t}\n" "\tnamespace eval configuresupport {\n" -"\t\tproc property {readslot writeslot args} {\n" +"\t\tproc PropertyImpl {readslot writeslot args} {\n" "\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n" "\t\t\t\tset prop [lindex $args $i]\n" "\t\t\t\tif {[string match \"-*\" $prop]} {\n" @@ -260,7 +260,8 @@ static const char *tclOOSetupScript = "\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n" "\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n" "\t\t\t\tset kind readwrite\n" -"\t\t\t\twhile {[string match \"-*\" [set next [lindex $args [expr {$i + 1}]]]]} {\n" +"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n" +"\t\t\t\t\t\tstring match \"-*\" $next]} {\n" "\t\t\t\t\tset arg [lindex $args [incr i 2]]\n" "\t\t\t\t\tswitch [::tcl::prefix match {-get -kind -set} $next] {\n" "\t\t\t\t\t\t-get {\n" @@ -290,50 +291,47 @@ static const char *tclOOSetupScript = "\t\t\t\t}\n" "\t\t\t\tswitch $kind {\n" "\t\t\t\t\treadable {\n" -"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list method {} $getter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {} $getter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\twritable {\n" -"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list method {value} $setter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\treadwrite {\n" -"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list method {} $getter]\n" -"\t\t\t\t\t\tuplevel 1 [list method {value} $setter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {} $getter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t}\n" "\t\t\t}\n" "\t\t}\n" "\t\tnamespace eval configurableclass {\n" "\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::property \\\n" +"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" -"\t\t\t\t\t::oo::configuresupport::writableproperties \\\n" -"\t\t\t\t\t{*}$args\n" +"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n" "\t\t\t}\n" "\t\t\tnamespace path ::oo::define\n" "\t\t}\n" "\t\tnamespace eval configurableobject {\n" "\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::property \\\n" +"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" -"\t\t\t\t\t::oo::configuresupport::objwritableproperties \\\n" -"\t\t\t\t\t{*}$args\n" +"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n" "\t\t\t}\n" "\t\t\tnamespace path ::oo::objdefine\n" "\t\t}\n" "\t}\n" -"\tclass create configurable {\n" -"\t\tsuperclass class\n" -"\t\tconstructor {{definitionScript \"\"}} {\n" -"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" -"\t\t\tnext $definitionScript\n" -"\t\t}\n" -"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" -"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" -"\t}\n" "\tclass create configuresupport::configurable {\n" "\t\tprivate method Configure:Match {prop kind} {\n" "\t\t\tset props [info object property [self] -all $kind]\n" @@ -362,6 +360,15 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t}\n" "\t}\n" +"\tclass create configurable {\n" +"\t\tsuperclass class\n" +"\t\tconstructor {{definitionScript \"\"}} {\n" +"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\t\tnext $definitionScript\n" +"\t\t}\n" +"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" +"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" +"\t}\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/tests/oo.test b/tests/oo.test index 235a90d..16045dd 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -342,7 +342,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as @@ -2424,7 +2424,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, property, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -2643,7 +2643,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, property, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { @@ -4186,7 +4186,7 @@ test oo-34.1 {TIP 380: slots - presence} -setup { } -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot} test oo-34.2 {TIP 380: slots - presence} { lsort [info class instances oo::Slot] -} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} +} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} proc getMethods obj { list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] @@ -5448,6 +5448,246 @@ test oo-43.13 {TIP 524: definition namespace control: user-level introspection} parent destroy namespace delete foodef } -result {{} {} ::foodef {} {}} + +test oo-44.1 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class property c] [info class property c -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test oo-44.2 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class property c -all] [info class property c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test oo-44.3 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class property c] [info class property c -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test oo-44.4 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class property c -all] [info class property c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test oo-44.5 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + oo::define d ::oo::configuresupport::readableproperties -set x y z + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + oo::define d ::oo::configuresupport::readableproperties -set r p q + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a h + oo::define d ::oo::configuresupport::readableproperties -set g h g + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] + oo::define d ::oo::configuresupport::readableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}} +test oo-44.6 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + oo::define d ::oo::configuresupport::writableproperties -set x y z + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + oo::define d ::oo::configuresupport::writableproperties -set r p q + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a h + oo::define d ::oo::configuresupport::writableproperties -set g h g + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] + oo::define d ::oo::configuresupport::writableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}} +test oo-44.7 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set + lappend result [info object property o] [info object property o -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}} +test oo-44.8 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set + lappend result [info object property o] [info object property o -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}} +test oo-44.9 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object property o -all] [info object property o -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b + oo::define d ::oo::configuresupport::readableproperties -set c d + oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f + lappend result [info object property o -all] [info object property o -writable -all] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e + lappend result [info object property o -all] [info object property o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c d e f} {} {a b c d e f} {}} +test oo-44.10 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object property o -all] [info object property o -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b + oo::define d ::oo::configuresupport::writableproperties -set c d + oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f + lappend result [info object property o -all] [info object property o -writable -all] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e + lappend result [info object property o -all] [info object property o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c d e f} {} {a b c d e f}} + +test oo-45.1 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + variable x y + method report {} { + lappend ::result "x=$x, y=$y" + } + } + set pt [Point new -x 3] + $pt report + $pt configure -y 4 + $pt report + lappend result [$pt configure -x],[$pt configure -y] [$pt configure] +} -cleanup { + parent destroy +} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}} +test oo-45.2 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -constraints knownBug -body { # FIXME # FIXME # FIXME # FIXME + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + set pt [Point new -x 3 -y 4] + oo::objdefine $pt property z + $pt configure -z 5 + lappend result [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + [$pt configure] +} -cleanup { + parent destroy +} -result {3,4,5 {-x 3 -y 4 -z 5}} cleanupTests return diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 8cc9627..5ae357a 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -450,15 +450,32 @@ # ---------------------------------------------------------------------- # - # oo::configurable -- + # oo::configuresupport -- + # + # Namespace that holds all the implementation details of TIP #558. + # Also includes the commands: # - # A metaclass that is used to make classes that can be configured. Also - # its supporting classes and namespaces. + # * readableproperties + # * writableproperties + # * objreadableproperties + # * objwritableproperties + # + # Those are all slot implementations that provide access to the C layer + # of property support (i.e., very fast cached lookup of property names). # # ---------------------------------------------------------------------- namespace eval configuresupport { - proc property {readslot writeslot args} { + + # ------------------------------------------------------------------ + # + # oo::configuresupport -- + # + # A metaclass that is used to make classes that can be configured. + # + # ------------------------------------------------------------------ + + proc PropertyImpl {readslot writeslot args} { for {set i 0} {$i < [llength $args]} {incr i} { # Parse the property name set prop [lindex $args $i] @@ -472,7 +489,8 @@ set kind readwrite # Parse the extra options - while {[string match "-*" [set next [lindex $args [expr {$i + 1}]]]]} { + while {[set next [lindex $args [expr {$i + 1}]] + string match "-*" $next]} { set arg [lindex $args [incr i 2]] switch [::tcl::prefix match {-get -kind -set} $next] { -get { @@ -504,80 +522,137 @@ # Install the option switch $kind { readable { - uplevel 1 [list $readslot -append $realprop] - uplevel 1 [list method {} $getter] + uplevel 1 [list \ + $readslot -append $realprop] + uplevel 1 [list \ + method {} $getter] } writable { - uplevel 1 [list $writeslot -append $realprop] - uplevel 1 [list method {value} $setter] + uplevel 1 [list \ + $writeslot -append $realprop] + uplevel 1 [list \ + method {value} $setter] } readwrite { - uplevel 1 [list $readslot -append $realprop] - uplevel 1 [list $writeslot -append $realprop] - uplevel 1 [list method {} $getter] - uplevel 1 [list method {value} $setter] + uplevel 1 [list \ + $readslot -append $realprop] + uplevel 1 [list \ + $writeslot -append $realprop] + uplevel 1 [list \ + method {} $getter] + uplevel 1 [list \ + method {value} $setter] } } } } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurableclass, + # oo::configuresupport::configurableobject -- + # + # Namespaces used as implementation vectors for oo::define and + # oo::objdefine when the class/instance is configurable. + # + # ------------------------------------------------------------------ + namespace eval configurableclass { proc property args { - tailcall ::oo::configuresupport::property \ + tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::readableproperties \ - ::oo::configuresupport::writableproperties \ - {*}$args + ::oo::configuresupport::writableproperties {*}$args } namespace path ::oo::define } + namespace eval configurableobject { proc property args { - tailcall ::oo::configuresupport::property \ + tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::objreadableproperties \ - ::oo::configuresupport::objwritableproperties \ - {*}$args + ::oo::configuresupport::objwritableproperties {*}$args } namespace path ::oo::objdefine } } - class create configurable { - superclass class - constructor {{definitionScript ""}} { - next {mixin ::oo::configuresupport::configurable} - next $definitionScript - } - definitionnamespace -class configuresupport::configurableclass - definitionnamespace -instance configuresupport::configurableobject - } + # ---------------------------------------------------------------------- + # + # oo::configuresupport::configurable -- + # + # The class that contains the implementation of the actual 'configure' + # method. + # + # ---------------------------------------------------------------------- class create configuresupport::configurable { + # + # Configure:Match -- + # Support method for doing the matching of property names + # (including unambiguous prefixes) to the actual real property + # name. + # private method Configure:Match {prop kind} { set props [info object property [self] -all $kind] ::tcl::prefix match -message "property" $props $prop } + + # + # configure -- + # Method for providing client access to the property mechanism. + # Has a user-facing API similar to that of [chan configure]. + # method configure args { if {[llength $args] == 0} { + # Read all properties set result {} foreach prop [info object property [self] -all -readable] { dict set result $prop [my ] } return $result } elseif {[llength $args] == 1} { + # Read a single property set prop [my Configure:Match [lindex $args 0] -readable] return [my ] } elseif {[llength $args] % 2 == 0} { + # Set properties, one or several foreach {prop value} $args { set prop [my Configure:Match $prop -writable] my $value } return } else { + # Invalid call return -code error -errorcode {TCL WRONGARGS} \ [format "wrong # args: should be \"%s\"" \ "[self] configure ?-option value ...?"] } } } + + # ---------------------------------------------------------------------- + # + # oo::configurable -- + # + # A metaclass that is used to make classes that can be configured. All + # the metaclass itself does is arrange for the class created to have a + # 'configure' method and for oo::define and oo::objdefine (on the class + # and its instances) to have a property definition for setting things up + # for 'configure'. + # + # ---------------------------------------------------------------------- + + class create configurable { + superclass class + + constructor {{definitionScript ""}} { + next {mixin ::oo::configuresupport::configurable} + next $definitionScript + } + + definitionnamespace -class configuresupport::configurableclass + definitionnamespace -instance configuresupport::configurableobject + } } # Local Variables: -- cgit v0.12 From a7a226fc4988c02841c106b4f1a8fd7af2c5a0c2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Dec 2019 13:23:47 +0000 Subject: Property definitions now work on instances. --- generic/tclOOCall.c | 9 +-- generic/tclOOScript.h | 81 ++++++++++++++---------- tests/oo.test | 2 +- tools/tclOOScript.tcl | 167 ++++++++++++++++++++++++++++++++------------------ 4 files changed, 164 insertions(+), 95 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index f647fb7..6b88b3d 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -59,6 +59,7 @@ typedef struct { #define BUILDING_MIXINS 0x400000 #define TRAVERSED_MIXIN 0x800000 #define OBJECT_MIXIN 0x1000000 +#define DEFINE_FOR_CLASS 0x2000000 #define MIXIN_CONSISTENT(flags) \ (((flags) & OBJECT_MIXIN) || \ !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) @@ -1896,7 +1897,7 @@ TclOOGetDefineContextNamespace( DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; DefineEntry *entryPtr; Tcl_Namespace *nsPtr = NULL; - int i; + int i, flags = (forClass ? DEFINE_FOR_CLASS : 0); define.list = staticSpace; define.num = 0; @@ -1907,8 +1908,8 @@ TclOOGetDefineContextNamespace( * class mixins right. */ - AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS); - AddSimpleDefineNamespaces(oPtr, &define, forClass); + AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS); + AddSimpleDefineNamespaces(oPtr, &define, flags); /* * Go through the list until we find a namespace whose name we can @@ -1992,7 +1993,7 @@ AddSimpleClassDefineNamespaces( flags | TRAVERSED_MIXIN); } - if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) { + if (flags & DEFINE_FOR_CLASS) { AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, definePtr, flags); } else { diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index b9223ee..8d8dd2a 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -29,7 +29,7 @@ static const char *tclOOSetupScript = "::namespace eval ::oo {\n" "\t::namespace path {}\n" "\tnamespace eval Helpers {\n" -"\t\t::namespace path {}\n" +"\t\tnamespace path {}\n" "\t\tproc callback {method args} {\n" "\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" "\t\t}\n" @@ -248,7 +248,7 @@ static const char *tclOOSetupScript = "\t\tsuperclass class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" -"\tnamespace eval configuresupport {\n" +"\t::namespace eval configuresupport {\n" "\t\tproc PropertyImpl {readslot writeslot args} {\n" "\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n" "\t\t\t\tset prop [lindex $args $i]\n" @@ -316,48 +316,66 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t}\n" "\t\tnamespace eval configurableclass {\n" -"\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" +"\t\t\t::proc property args {\n" +"\t\t\t\t::tailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n" "\t\t\t}\n" -"\t\t\tnamespace path ::oo::define\n" +"\t\t\t::namespace path ::oo::define\n" +"\t\t\t::namespace export property\n" "\t\t}\n" "\t\tnamespace eval configurableobject {\n" -"\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" +"\t\t\t::proc property args {\n" +"\t\t\t\t::tailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n" "\t\t\t}\n" -"\t\t\tnamespace path ::oo::objdefine\n" +"\t\t\t::namespace path ::oo::objdefine\n" +"\t\t\t::namespace export property\n" "\t\t}\n" -"\t}\n" -"\tclass create configuresupport::configurable {\n" -"\t\tprivate method Configure:Match {prop kind} {\n" -"\t\t\tset props [info object property [self] -all $kind]\n" -"\t\t\t::tcl::prefix match -message \"property\" $props $prop\n" +"\t\tproc ReadAll {object my} {\n" +"\t\t\tset result {}\n" +"\t\t\tforeach prop [info object property $object -all -readable] {\n" +"\t\t\t\tdict set result $prop [$my ]\n" +"\t\t\t}\n" +"\t\t\treturn $result\n" "\t\t}\n" -"\t\tmethod configure args {\n" -"\t\t\tif {[llength $args] == 0} {\n" -"\t\t\t\tset result {}\n" -"\t\t\t\tforeach prop [info object property [self] -all -readable] {\n" -"\t\t\t\t\tdict set result $prop [my ]\n" +"\t\tproc Match {object propertyName kind} {\n" +"\t\t\tset props [info object property $object -all $kind]\n" +"\t\t\t::tcl::prefix match -message \"property\" $props $propertyName\n" +"\t\t}\n" +"\t\tproc ReadOne {object my propertyName} {\n" +"\t\t\tset prop [Match $object $propertyName -readable]\n" +"\t\t\treturn [$my ]\n" +"\t\t}\n" +"\t\tproc WriteMany {object my setterMap} {\n" +"\t\t\tforeach {prop value} $setterMap {\n" +"\t\t\t\tset prop [Match $object $prop -writable]\n" +"\t\t\t\t$my $value\n" +"\t\t\t}\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\t::oo::class create configurable {\n" +"\t\t\tprivate variable my\n" +"\t\t\tmethod configure args {\n" +"\t\t\t\t::if {![::info exists my]} {\n" +"\t\t\t\t\t::set my [::namespace which my]\n" "\t\t\t\t}\n" -"\t\t\t\treturn $result\n" -"\t\t\t} elseif {[llength $args] == 1} {\n" -"\t\t\t\tset prop [my Configure:Match [lindex $args 0] -readable]\n" -"\t\t\t\treturn [my ]\n" -"\t\t\t} elseif {[llength $args] % 2 == 0} {\n" -"\t\t\t\tforeach {prop value} $args {\n" -"\t\t\t\t\tset prop [my Configure:Match $prop -writable]\n" -"\t\t\t\t\tmy $value\n" +"\t\t\t\t::if {[::llength $args] == 0} {\n" +"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n" +"\t\t\t\t} elseif {[::llength $args] == 1} {\n" +"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n" +"\t\t\t\t\t\t[::lindex $args 0]\n" +"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n" +"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n" +"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n" "\t\t\t\t}\n" -"\t\t\t\treturn\n" -"\t\t\t} else {\n" -"\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" -"\t\t\t\t\t[format \"wrong # args: should be \\\"%s\\\"\" \\\n" -"\t\t\t\t\t\t \"[self] configure \?-option value ...\?\"]\n" "\t\t\t}\n" +"\t\t\tdefinitionnamespace -instance configurableobject\n" +"\t\t\tdefinitionnamespace -class configurableclass\n" "\t\t}\n" "\t}\n" "\tclass create configurable {\n" @@ -367,7 +385,6 @@ static const char *tclOOSetupScript = "\t\t\tnext $definitionScript\n" "\t\t}\n" "\t\tdefinitionnamespace -class configuresupport::configurableclass\n" -"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" "\t}\n" "}\n" /* !END!: Do not edit above this line. */ diff --git a/tests/oo.test b/tests/oo.test index 16045dd..32a0cf1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5672,7 +5672,7 @@ test oo-45.2 {TIP 558: properties: configurable class system} -setup { oo::class create parent unset -nocomplain result set result {} -} -constraints knownBug -body { # FIXME # FIXME # FIXME # FIXME +} -body { oo::configurable create Point { superclass parent property x y diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 5ae357a..b441765 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -18,7 +18,7 @@ # Commands that are made available to objects by default. # namespace eval Helpers { - ::namespace path {} + namespace path {} # ------------------------------------------------------------------ # @@ -465,7 +465,7 @@ # # ---------------------------------------------------------------------- - namespace eval configuresupport { + ::namespace eval configuresupport { # ------------------------------------------------------------------ # @@ -558,75 +558,127 @@ # ------------------------------------------------------------------ namespace eval configurableclass { - proc property args { - tailcall ::oo::configuresupport::PropertyImpl \ + ::proc property args { + ::tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::readableproperties \ ::oo::configuresupport::writableproperties {*}$args } - namespace path ::oo::define + ::namespace path ::oo::define + ::namespace export property } namespace eval configurableobject { - proc property args { - tailcall ::oo::configuresupport::PropertyImpl \ + ::proc property args { + ::tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::objreadableproperties \ ::oo::configuresupport::objwritableproperties {*}$args } - namespace path ::oo::objdefine + ::namespace path ::oo::objdefine + ::namespace export property } - } - # ---------------------------------------------------------------------- - # - # oo::configuresupport::configurable -- - # - # The class that contains the implementation of the actual 'configure' - # method. - # - # ---------------------------------------------------------------------- + # ------------------------------------------------------------------ + # + # oo::configuresupport::ReadAll -- + # + # The implementation of [$o configure] with no extra arguments. + # + # ------------------------------------------------------------------ + + proc ReadAll {object my} { + set result {} + foreach prop [info object property $object -all -readable] { + dict set result $prop [$my ] + } + return $result + } - class create configuresupport::configurable { + # ------------------------------------------------------------------ # - # Configure:Match -- - # Support method for doing the matching of property names - # (including unambiguous prefixes) to the actual real property - # name. - # - private method Configure:Match {prop kind} { - set props [info object property [self] -all $kind] - ::tcl::prefix match -message "property" $props $prop + # oo::configuresupport::Match -- + # + # How to convert an imprecise property name into a full one. + # + # ------------------------------------------------------------------ + + proc Match {object propertyName kind} { + set props [info object property $object -all $kind] + ::tcl::prefix match -message "property" $props $propertyName } + # ------------------------------------------------------------------ # - # configure -- - # Method for providing client access to the property mechanism. - # Has a user-facing API similar to that of [chan configure]. - # - method configure args { - if {[llength $args] == 0} { - # Read all properties - set result {} - foreach prop [info object property [self] -all -readable] { - dict set result $prop [my ] + # oo::configuresupport::ReadOne -- + # + # The implementation of [$o configure -prop] with that single + # extra argument. + # + # ------------------------------------------------------------------ + + proc ReadOne {object my propertyName} { + set prop [Match $object $propertyName -readable] + return [$my ] + } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::WriteMany -- + # + # The implementation of [$o configure -prop val ?-prop val...?]. + # + # ------------------------------------------------------------------ + + proc WriteMany {object my setterMap} { + foreach {prop value} $setterMap { + set prop [Match $object $prop -writable] + $my $value + } + return + } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurable -- + # + # The class that contains the implementation of the actual + # 'configure' method (mixed into actually configurable classes). + # Great care needs to be taken in these methods as they are + # potentially used in classes where the current namespace is set + # up very strangely. + # + # ------------------------------------------------------------------ + + ::oo::class create configurable { + private variable my + # + # configure -- + # Method for providing client access to the property mechanism. + # Has a user-facing API similar to that of [chan configure]. + # + method configure args { + ::if {![::info exists my]} { + ::set my [::namespace which my] } - return $result - } elseif {[llength $args] == 1} { - # Read a single property - set prop [my Configure:Match [lindex $args 0] -readable] - return [my ] - } elseif {[llength $args] % 2 == 0} { - # Set properties, one or several - foreach {prop value} $args { - set prop [my Configure:Match $prop -writable] - my $value + ::if {[::llength $args] == 0} { + # Read all properties + ::oo::configuresupport::ReadAll [self] $my + } elseif {[::llength $args] == 1} { + # Read a single property + ::oo::configuresupport::ReadOne [self] $my \ + [::lindex $args 0] + } elseif {[::llength $args] % 2 == 0} { + # Set properties, one or several + ::oo::configuresupport::WriteMany [self] $my $args + } else { + # Invalid call + ::return -code error -errorcode {TCL WRONGARGS} \ + [::format {wrong # args: should be "%s"} \ + "[self] configure ?-option value ...?"] } - return - } else { - # Invalid call - return -code error -errorcode {TCL WRONGARGS} \ - [format "wrong # args: should be \"%s\"" \ - "[self] configure ?-option value ...?"] } + + definitionnamespace -instance configurableobject + definitionnamespace -class configurableclass } } @@ -634,11 +686,11 @@ # # oo::configurable -- # - # A metaclass that is used to make classes that can be configured. All - # the metaclass itself does is arrange for the class created to have a - # 'configure' method and for oo::define and oo::objdefine (on the class - # and its instances) to have a property definition for setting things up - # for 'configure'. + # A metaclass that is used to make classes that can be configured in + # their creation phase (and later too). All the metaclass itself does is + # arrange for the class created to have a 'configure' method and for + # oo::define and oo::objdefine (on the class and its instances) to have + # a property definition for setting things up for 'configure'. # # ---------------------------------------------------------------------- @@ -651,7 +703,6 @@ } definitionnamespace -class configuresupport::configurableclass - definitionnamespace -instance configuresupport::configurableobject } } -- cgit v0.12 From c15b6135d53724df6ead08563d101ff24a98c812 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2019 10:12:16 +0000 Subject: More tests, more fixes --- generic/tclOOScript.h | 62 +++++--- tests/oo.test | 398 +++++++++++++++++++++++++++++++++++++++++++++++++- tools/tclOOScript.tcl | 71 +++++---- 3 files changed, 473 insertions(+), 58 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 8d8dd2a..7a4a0bb 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -249,11 +249,13 @@ static const char *tclOOSetupScript = "\t\tunexport create createWithNamespace new\n" "\t}\n" "\t::namespace eval configuresupport {\n" +"\t\tnamespace path ::tcl\n" "\t\tproc PropertyImpl {readslot writeslot args} {\n" "\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n" "\t\t\t\tset prop [lindex $args $i]\n" "\t\t\t\tif {[string match \"-*\" $prop]} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\treturn -code error -level 2 \\\n" +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" "\t\t\t\t\t\t\"bad property name \\\"$prop\\\"; must not begin with -\"\n" "\t\t\t\t}\n" "\t\t\t\tset realprop [string cat \"-\" $prop]\n" @@ -263,27 +265,33 @@ static const char *tclOOSetupScript = "\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n" "\t\t\t\t\t\tstring match \"-*\" $next]} {\n" "\t\t\t\t\tset arg [lindex $args [incr i 2]]\n" -"\t\t\t\t\tswitch [::tcl::prefix match {-get -kind -set} $next] {\n" +"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n" +"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n" "\t\t\t\t\t\t-get {\n" "\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n" -"\t\t\t\t\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n" +"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n" "\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n" "\t\t\t\t\t\t\t}\n" "\t\t\t\t\t\t\tset getter $arg\n" "\t\t\t\t\t\t}\n" "\t\t\t\t\t\t-set {\n" "\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n" -"\t\t\t\t\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n" +"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n" "\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n" "\t\t\t\t\t\t\t}\n" -"\t\t\t\t\t\t\tset getter $arg\n" +"\t\t\t\t\t\t\tset setter $arg\n" "\t\t\t\t\t\t}\n" "\t\t\t\t\t\t-kind {\n" "\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n" -"\t\t\t\t\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n" +"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n" "\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n" "\t\t\t\t\t\t\t}\n" -"\t\t\t\t\t\t\tset kind [::tcl::prefix match -message \"kind\" {\n" +"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n" +"\t\t\t\t\t\t\t\t\t-level 2 \\\n" +"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n" "\t\t\t\t\t\t\t\treadable readwrite writable\n" "\t\t\t\t\t\t\t} $arg]\n" "\t\t\t\t\t\t}\n" @@ -291,25 +299,29 @@ static const char *tclOOSetupScript = "\t\t\t\t}\n" "\t\t\t\tswitch $kind {\n" "\t\t\t\t\treadable {\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" +"\t\t\t\t\t\t\t\t$writeslot -remove $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\tmethod {} $getter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\twritable {\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" +"\t\t\t\t\t\t\t\t$readslot -remove $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\tmethod {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\treadwrite {\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\tmethod {} $getter]\n" -"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\tuplevel 2 [list \\\n" "\t\t\t\t\t\t\t\tmethod {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t}\n" @@ -317,7 +329,7 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\tnamespace eval configurableclass {\n" "\t\t\t::proc property args {\n" -"\t\t\t\t::tailcall ::oo::configuresupport::PropertyImpl \\\n" +"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n" "\t\t\t}\n" @@ -326,7 +338,7 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\tnamespace eval configurableobject {\n" "\t\t\t::proc property args {\n" -"\t\t\t\t::tailcall ::oo::configuresupport::PropertyImpl \\\n" +"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n" "\t\t\t}\n" @@ -340,17 +352,21 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t\treturn $result\n" "\t\t}\n" -"\t\tproc Match {object propertyName kind} {\n" -"\t\t\tset props [info object property $object -all $kind]\n" -"\t\t\t::tcl::prefix match -message \"property\" $props $propertyName\n" -"\t\t}\n" "\t\tproc ReadOne {object my propertyName} {\n" -"\t\t\tset prop [Match $object $propertyName -readable]\n" +"\t\t\tset props [info object property $object -all -readable]\n" +"\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" +"\t\t\t\t\t-level 2 -errorcode [list \\\n" +"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName]] \\\n" +"\t\t\t\t\t\t $props $propertyName]\n" "\t\t\treturn [$my ]\n" "\t\t}\n" "\t\tproc WriteMany {object my setterMap} {\n" +"\t\t\tset props [info object property $object -all -writable]\n" "\t\t\tforeach {prop value} $setterMap {\n" -"\t\t\t\tset prop [Match $object $prop -writable]\n" +"\t\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" +"\t\t\t\t\t-level 2 -errorcode [list \\\n" +"\t\t\t\t\t\tTCL LOOKUP INDEX property $prop]] \\\n" +"\t\t\t\t\t\t\t $props $prop]\n" "\t\t\t\t$my $value\n" "\t\t\t}\n" "\t\t\treturn\n" diff --git a/tests/oo.test b/tests/oo.test index 32a0cf1..f86b33a 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5670,8 +5670,29 @@ test oo-45.1 {TIP 558: properties: configurable class system} -setup { } -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}} test oo-45.2 {TIP 558: properties: configurable class system} -setup { oo::class create parent - unset -nocomplain result - set result {} +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + oo::configurable create 3DPoint { + superclass Point + property z + constructor args { + next -z 0 {*}$args + } + } + set pt [3DPoint new -x 3 -y 4 -z 5] + list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + [$pt configure] +} -cleanup { + parent destroy +} -result {3,4,5 {-x 3 -y 4 -z 5}} +test oo-45.3 {TIP 558: properties: configurable class system} -setup { + oo::class create parent } -body { oo::configurable create Point { superclass parent @@ -5683,11 +5704,382 @@ test oo-45.2 {TIP 558: properties: configurable class system} -setup { set pt [Point new -x 3 -y 4] oo::objdefine $pt property z $pt configure -z 5 - lappend result [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ [$pt configure] } -cleanup { parent destroy } -result {3,4,5 {-x 3 -y 4 -z 5}} +test oo-45.4 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + [Point new] configure gorp +} -returnCodes error -cleanup { + parent destroy +} -result {bad property "gorp": must be -x or -y} +test oo-45.5 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + oo::configurable create 3DPoint { + superclass Point + property z + constructor args { + next -z 0 {*}$args + } + } + [3DPoint new] configure gorp +} -returnCodes error -cleanup { + parent destroy +} -result {bad property "gorp": must be -x, -y, or -z} +test oo-45.6 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + [Point create p] configure -x 1 -y +} -returnCodes error -cleanup { + parent destroy +} -result {wrong # args: should be "::p configure ?-option value ...?"} +test oo-45.7 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + property x y -kind writable + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + Point create p + list [p configure -y ok] [catch {p configure -y} msg] $msg +} -cleanup { + parent destroy +} -result {{} 1 {bad property "-y": must be -x}} +test oo-45.8 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + property x y -kind readable + constructor args { + my configure -x 0 {*}$args + variable y 123 + } + } + Point create p + list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg +} -cleanup { + parent destroy +} -result {{-x 0 -y 123} 123 1 {bad property "-y": must be -x}} + +test oo-46.1 {ITP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property x -get { + global result + lappend result "get" + return [lrepeat 3 $xyz] + } -set { + global result + lappend result [list set $value] + set xyz [expr {$value * 3}] + } + } + Point create pt + pt configure -x 5 + lappend result >[pt configure -x]< +} -cleanup { + parent destroy +} -result {{set 5} get {>15 15 15<}} +test oo-46.2 {ITP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property x -get { + global result + lappend result "get" + return [lrepeat 3 $xyz] + } -set { + global result + lappend result [list set $value] + set xyz [expr {$value * 3}] + } y -kind readable -get {return $xyz} + } + Point create pt + pt configure -x 5 + lappend result >[pt configure -x]< [pt configure -y] +} -cleanup { + parent destroy +} -result {{set 5} get {>15 15 15<} 15} +test oo-46.2 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property -x -get {return $xyz} + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "-x"; must not begin with -} +test oo-46.3 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -get + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -get option} +test oo-46.4 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -set + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -set option} +test oo-46.5 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -kind + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing kind value to go with -kind option} +test oo-46.6 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -get {} -set + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -set option} +test oo-46.7 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -get {} -get {return ok} + } + [Point new] configure -x +} -cleanup { + parent destroy +} -result ok +test oo-46.8 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -kind gorp + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad kind "gorp": must be readable, readwrite, or writable} +test oo-46.9 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -k reada -g {return ok} + } + [Point new] configure -x +} -cleanup { + parent destroy +} -result ok +test oo-46.10 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property {*}{ + x -kind writable + y -get {return ok} + } + } + [Point new] configure -y +} -cleanup { + parent destroy +} -result ok +test oo-46.11 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xy + property x -kind readable -get {return $xy} + property x -kind writable -set {set xy $value} + property y + } + Point create pt + list [catch { + pt configure -x ok + } msg] $msg [catch { + pt configure -x + } msg] $msg +} -cleanup { + parent destroy +} -result {0 {} 1 {bad property "-x": must be -y}} + +test oo-47.1 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property -x}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property name "-x"; must not begin with - + while executing +"property -x" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}} +test oo-47.2 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -get}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing body to go with -get option + while executing +"property x -get" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -get}"} {TCL WRONGARGS}} +test oo-47.3 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -set}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing body to go with -set option + while executing +"property x -set" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -set}"} {TCL WRONGARGS}} +test oo-47.4 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -kind}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing kind value to go with -kind option + while executing +"property x -kind" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -kind}"} {TCL WRONGARGS}} +test oo-47.5 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -kind gorp}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad kind "gorp": must be readable, readwrite, or writable + while executing +"property x -kind gorp" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}} +test oo-47.6 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -gorp}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad option "-gorp": must be -get, -kind, or -set + while executing +"property x -gorp" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}} +test oo-47.7 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point { + superclass parent + property x + } + Point create pt + list [catch {pt configure -gorp} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property "-gorp": must be -x + while executing +"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}} +test oo-47.8 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point { + superclass parent + property x + } + Point create pt + list [catch {pt configure -gorp blarg} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property "-gorp": must be -x + while executing +"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}} cleanupTests return diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index b441765..4dbc48c 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -466,6 +466,7 @@ # ---------------------------------------------------------------------- ::namespace eval configuresupport { + namespace path ::tcl # ------------------------------------------------------------------ # @@ -480,7 +481,8 @@ # Parse the property name set prop [lindex $args $i] if {[string match "-*" $prop]} { - return -code error -errorcode {TCLOO PROPERTY_FORMAT} \ + return -code error -level 2 \ + -errorcode {TCLOO PROPERTY_FORMAT} \ "bad property name \"$prop\"; must not begin with -" } set realprop [string cat "-" $prop] @@ -492,27 +494,33 @@ while {[set next [lindex $args [expr {$i + 1}]] string match "-*" $next]} { set arg [lindex $args [incr i 2]] - switch [::tcl::prefix match {-get -kind -set} $next] { + switch [prefix match -error [list -level 2 -errorcode \ + [list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] { -get { if {$i >= [llength $args]} { - return -code error -errorcode {TCL WRONGARGS} \ + return -code error -level 2 \ + -errorcode {TCL WRONGARGS} \ "missing body to go with -get option" } set getter $arg } -set { if {$i >= [llength $args]} { - return -code error -errorcode {TCL WRONGARGS} \ + return -code error -level 2 \ + -errorcode {TCL WRONGARGS} \ "missing body to go with -set option" } - set getter $arg + set setter $arg } -kind { if {$i >= [llength $args]} { - return -code error -errorcode {TCL WRONGARGS} \ + return -code error -level 2\ + -errorcode {TCL WRONGARGS} \ "missing kind value to go with -kind option" } - set kind [::tcl::prefix match -message "kind" { + set kind [prefix match -message "kind" -error [list \ + -level 2 \ + -errorcode [list TCL LOOKUP INDEX kind $arg]] { readable readwrite writable } $arg] } @@ -522,25 +530,29 @@ # Install the option switch $kind { readable { - uplevel 1 [list \ + uplevel 2 [list \ $readslot -append $realprop] - uplevel 1 [list \ + uplevel 2 [list \ + $writeslot -remove $realprop] + uplevel 2 [list \ method {} $getter] } writable { - uplevel 1 [list \ + uplevel 2 [list \ + $readslot -remove $realprop] + uplevel 2 [list \ $writeslot -append $realprop] - uplevel 1 [list \ + uplevel 2 [list \ method {value} $setter] } readwrite { - uplevel 1 [list \ + uplevel 2 [list \ $readslot -append $realprop] - uplevel 1 [list \ + uplevel 2 [list \ $writeslot -append $realprop] - uplevel 1 [list \ + uplevel 2 [list \ method {} $getter] - uplevel 1 [list \ + uplevel 2 [list \ method {value} $setter] } } @@ -559,7 +571,7 @@ namespace eval configurableclass { ::proc property args { - ::tailcall ::oo::configuresupport::PropertyImpl \ + ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::readableproperties \ ::oo::configuresupport::writableproperties {*}$args } @@ -569,7 +581,7 @@ namespace eval configurableobject { ::proc property args { - ::tailcall ::oo::configuresupport::PropertyImpl \ + ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::objreadableproperties \ ::oo::configuresupport::objwritableproperties {*}$args } @@ -595,19 +607,6 @@ # ------------------------------------------------------------------ # - # oo::configuresupport::Match -- - # - # How to convert an imprecise property name into a full one. - # - # ------------------------------------------------------------------ - - proc Match {object propertyName kind} { - set props [info object property $object -all $kind] - ::tcl::prefix match -message "property" $props $propertyName - } - - # ------------------------------------------------------------------ - # # oo::configuresupport::ReadOne -- # # The implementation of [$o configure -prop] with that single @@ -616,7 +615,11 @@ # ------------------------------------------------------------------ proc ReadOne {object my propertyName} { - set prop [Match $object $propertyName -readable] + set props [info object property $object -all -readable] + set prop [prefix match -message "property" -error [list\ + -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $propertyName]] \ + $props $propertyName] return [$my ] } @@ -629,8 +632,12 @@ # ------------------------------------------------------------------ proc WriteMany {object my setterMap} { + set props [info object property $object -all -writable] foreach {prop value} $setterMap { - set prop [Match $object $prop -writable] + set prop [prefix match -message "property" -error [list\ + -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $prop]] \ + $props $prop] $my $value } return -- cgit v0.12 From 6eb109c913cd2b43ad9298df8f9eaf9e66c75a77 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 30 Dec 2019 15:35:51 +0000 Subject: Even more tests, this time of the return-code semantics of property getters and setters. --- generic/tclOOScript.h | 49 +++++++++++++- tests/oo.test | 174 +++++++++++++++++++++++++++++++++++++++++++++++--- tools/tclOOScript.tcl | 49 +++++++++++++- 3 files changed, 256 insertions(+), 16 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 7a4a0bb..e8fd814 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -348,7 +348,21 @@ static const char *tclOOSetupScript = "\t\tproc ReadAll {object my} {\n" "\t\t\tset result {}\n" "\t\t\tforeach prop [info object property $object -all -readable] {\n" -"\t\t\t\tdict set result $prop [$my ]\n" +"\t\t\t\ttry {\n" +"\t\t\t\t\tdict set result $prop [$my ]\n" +"\t\t\t\t} on error {msg opt} {\n" +"\t\t\t\t\tdict set opt -level 2\n" +"\t\t\t\t\treturn -options $opt $msg\n" +"\t\t\t\t} on return {msg opt} {\n" +"\t\t\t\t\tdict incr opt -level 2\n" +"\t\t\t\t\treturn -options $opt $msg\n" +"\t\t\t\t} on break {} {\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\t\t\"property getter for $prop did a break\"\n" +"\t\t\t\t} on continue {} {\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n" +"\t\t\t\t}\n" "\t\t\t}\n" "\t\t\treturn $result\n" "\t\t}\n" @@ -358,7 +372,22 @@ static const char *tclOOSetupScript = "\t\t\t\t\t-level 2 -errorcode [list \\\n" "\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName]] \\\n" "\t\t\t\t\t\t $props $propertyName]\n" -"\t\t\treturn [$my ]\n" +"\t\t\ttry {\n" +"\t\t\t\tset value [$my ]\n" +"\t\t\t} on error {msg opt} {\n" +"\t\t\t\tdict set opt -level 2\n" +"\t\t\t\treturn -options $opt $msg\n" +"\t\t\t} on return {msg opt} {\n" +"\t\t\t\tdict incr opt -level 2\n" +"\t\t\t\treturn -options $opt $msg\n" +"\t\t\t} on break {} {\n" +"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\t\"property getter for $prop did a break\"\n" +"\t\t\t} on continue {} {\n" +"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\t\"property getter for $prop did a continue\"\n" +"\t\t\t}\n" +"\t\t\treturn $value\n" "\t\t}\n" "\t\tproc WriteMany {object my setterMap} {\n" "\t\t\tset props [info object property $object -all -writable]\n" @@ -367,7 +396,21 @@ static const char *tclOOSetupScript = "\t\t\t\t\t-level 2 -errorcode [list \\\n" "\t\t\t\t\t\tTCL LOOKUP INDEX property $prop]] \\\n" "\t\t\t\t\t\t\t $props $prop]\n" -"\t\t\t\t$my $value\n" +"\t\t\t\ttry {\n" +"\t\t\t\t\t$my $value\n" +"\t\t\t\t} on error {msg opt} {\n" +"\t\t\t\t\tdict set opt -level 2\n" +"\t\t\t\t\treturn -options $opt $msg\n" +"\t\t\t\t} on return {msg opt} {\n" +"\t\t\t\t\tdict incr opt -level 2\n" +"\t\t\t\t\treturn -options $opt $msg\n" +"\t\t\t\t} on break {} {\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\t\t\"property setter for $prop did a break\"\n" +"\t\t\t\t} on continue {} {\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n" +"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n" +"\t\t\t\t}\n" "\t\t\t}\n" "\t\t\treturn\n" "\t\t}\n" diff --git a/tests/oo.test b/tests/oo.test index f86b33a..631c84d 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5894,8 +5894,8 @@ test oo-46.6 {TIP 558: properties: declaration semantics} -setup { test oo-46.7 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { - oo::configurable create Point {superclass parent} - oo::define Point { + oo::configurable create Point { + superclass parent property x -get {} -get {return ok} } [Point new] configure -x @@ -5905,8 +5905,8 @@ test oo-46.7 {TIP 558: properties: declaration semantics} -setup { test oo-46.8 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { - oo::configurable create Point {superclass parent} - oo::define Point { + oo::configurable create Point { + superclass parent property x -kind gorp } } -returnCodes error -cleanup { @@ -5915,8 +5915,8 @@ test oo-46.8 {TIP 558: properties: declaration semantics} -setup { test oo-46.9 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { - oo::configurable create Point {superclass parent} - oo::define Point { + oo::configurable create Point { + superclass parent property x -k reada -g {return ok} } [Point new] configure -x @@ -5926,8 +5926,8 @@ test oo-46.9 {TIP 558: properties: declaration semantics} -setup { test oo-46.10 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { - oo::configurable create Point {superclass parent} - oo::define Point { + oo::configurable create Point { + superclass parent property {*}{ x -kind writable y -get {return ok} @@ -5941,8 +5941,8 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup { oo::class create parent unset -nocomplain msg } -body { - oo::configurable create Point {superclass parent} - oo::define Point { + oo::configurable create Point { + superclass parent variable xy property x -kind readable -get {return $xy} property x -kind writable -set {set xy $value} @@ -5957,6 +5957,160 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result {0 {} 1 {bad property "-x": must be -y}} +test oo-46.12 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code break} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a break} +test oo-46.13 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code break} + } + while 1 { + [Point new] configure + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a break} +test oo-46.14 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {error "boo"} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test oo-46.15 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {error "boo"} + } + while 1 { + [Point new] configure + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test oo-46.16 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code continue} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a continue} +test oo-46.17 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -level 2 ok} + } + apply {{} { + [Point new] configure + return bad + }} +} -cleanup { + parent destroy +} -result ok +test oo-46.18 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -level 2 ok} + } + apply {{} { + [Point new] configure -x + return bad + }} +} -cleanup { + parent destroy +} -result ok +test oo-46.19 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -code break} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property setter for -x did a break} +test oo-46.20 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -code continue} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property setter for -x did a continue} +test oo-46.21 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {error "boo"} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test oo-46.22 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -level 2 ok} + } + apply {{} { + [Point new] configure -x gorp + return bad + }} +} -cleanup { + parent destroy +} -result ok test oo-47.1 {TIP 558: properties: error details} -setup { oo::class create parent diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 4dbc48c..56a7bf8 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -600,7 +600,21 @@ proc ReadAll {object my} { set result {} foreach prop [info object property $object -all -readable] { - dict set result $prop [$my ] + try { + dict set result $prop [$my ] + } on error {msg opt} { + dict set opt -level 2 + return -options $opt $msg + } on return {msg opt} { + dict incr opt -level 2 + return -options $opt $msg + } on break {} { + return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + "property getter for $prop did a break" + } on continue {} { + return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + "property getter for $prop did a continue" + } } return $result } @@ -620,7 +634,22 @@ -level 2 -errorcode [list \ TCL LOOKUP INDEX property $propertyName]] \ $props $propertyName] - return [$my ] + try { + set value [$my ] + } on error {msg opt} { + dict set opt -level 2 + return -options $opt $msg + } on return {msg opt} { + dict incr opt -level 2 + return -options $opt $msg + } on break {} { + return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + "property getter for $prop did a break" + } on continue {} { + return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + "property getter for $prop did a continue" + } + return $value } # ------------------------------------------------------------------ @@ -638,7 +667,21 @@ -level 2 -errorcode [list \ TCL LOOKUP INDEX property $prop]] \ $props $prop] - $my $value + try { + $my $value + } on error {msg opt} { + dict set opt -level 2 + return -options $opt $msg + } on return {msg opt} { + dict incr opt -level 2 + return -options $opt $msg + } on break {} { + return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + "property setter for $prop did a break" + } on continue {} { + return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \ + "property setter for $prop did a continue" + } } return } -- cgit v0.12 From d4b3d3a460efcdaa6f0ef897a6c3e52b3331e421 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2019 14:56:32 +0000 Subject: Added docs --- doc/configurable.n | 334 +++++++++++++++++++++++++++++++++++++++++++++++++++++ doc/info.n | 47 ++++++++ 2 files changed, 381 insertions(+) create mode 100644 doc/configurable.n diff --git a/doc/configurable.n b/doc/configurable.n new file mode 100644 index 0000000..f01f051 --- /dev/null +++ b/doc/configurable.n @@ -0,0 +1,334 @@ +'\" +'\" Copyright (c) 2019 Donal K. Fellows +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH configurable n 0.1 TclOO "TclOO Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties +.SH SYNOPSIS +.nf +package require TclOO + +\fBoo::configurable create \fIclass\fR \fR?\fIdefinitionScript\fR? + +\fBoo::define \fIclass\fB {\fR + \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...? +\fB}\fR + +\fBoo::objdefine \fIobject\fB {\fR + \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...? +\fB}\fR + +\fIobjectName \fBconfigure\fR +\fIobjectName \fBconfigure\fR \fI\-prop\fR +\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR...\fR +.fi +.SH "CLASS HIERARCHY" +.nf +\fBoo::object\fR + \(-> \fBoo::class\fR + \(-> \fBoo::configurable\fR + +\fBoo::object\fR + \(-> \fBoo::class\fR + \(-> \fBoo::configurablesupport::configurable\fR +.fi +.BE +.SH DESCRIPTION +.PP +Configurable objects are objects that support being configured with a +\fBconfigure\fR method. Each of the configurable entities of the object is +known as a property of the object. Properties may be defined on classes or +instances; when configuring an object, any of the properties defined by its +classes (direct or indirect) or by the instance itself may be configured. +.PP +The \fBoo::configurable\fR metaclass installs basic support for making +configurable objects into a class. This consists of making a \fBproperty\fR +definition command available in definition scripts for the class and instances +(e.g., from the class's constructor, within \fBoo::define\fR and within +\fBoo::objdefine\fR) and making a \fBconfigure\fR method available within the +instances. +.SS "CONFIGURE METHOD" +.PP +The behavior of the \fBconfigure\fR method is modelled after the +\fBfconfigure\fR/\fBchan configure\fR command. +.PP +If passed no additional arguments, the \fBconfigure\fR method returns an +alphabetically sorted dictionary of all \fIreadable\fR and \fIread-write\fR +properties and their current values. +.PP +If passed a single addiional argument, that argument to the \fBconfigure\fR +method must be the name of a property to read (or an unambiguous prefix +thereof); its value is returned. +.PP +Otherwise, if passed an even number of arguments then each pair of arguments +specifies a property name (or an unambiguous prefix thereof) and the value to +set it to. The properties will be set in the order specified, including +duplicates. If the setting of any property fails, the overall \fBconfigure\fR +method fails, the preceding pairs (if any) will continue to have been applied, +and the succeeding pairs (if any) will be not applied. On success, the result +of the \fBconfigure\fR method in this mode operation will be an empty string. +.SS "PROPERTY DEFINITIONS" +.PP +When a class has been manufactured by the \fBoo::configurable\fR metaclass (or +one of its subclasses), it gains an extra definition, \fBproperty\fR. The +\fBproperty\fR definition defines one or more properties that will be exposed +by the class's instances. +.PP +The \fBproperty\fR command takes the name of a property to define first, +\fIwithout a leading hyphen\fR, followed by a number of option-value pairs +that modify the basic behavior of the property. This can then be followed by +an arbitrary number of other property definitions. The supported options are: +.TP +\fB\-get \fIgetterScript\fR +. +This defines the implementation of how to read from the property; the +\fIgetterScript\fR will become the body of a method (taking no arguments) +defined on the class, if the kind of the property is such that the property +can be read from. The method will be named +\fB\fR, and will default to being a simple read +of the instance variable with the same name as the property (e.g., +.QW "\fBproperty\fR xyz" +will result in a method +.QW +being created). +.TP +\fB\-kind \fIpropertyKind\fR +. +This defines what sort of property is being created. The \fIpropertyKind\fR +must be exactly one of \fBreadable\fR, \fBwritable\fR, or \fBreadwrite\fR +(which is the default) which will make the property read-only, write-only or +read-write, respectively. Read-only properties can only ever be read from, +write-only properties can only ever be written to, and read-write properties +can be both read and written. +.RS +.PP +Note that write-only properties are not particularly discoverable as they are +never reported by the \fBconfigure\fR method other than by error messages when +attempting to write to a property that does not exist. +.RE +.TP +\fB\-set \fIsetterScript\fR +. +This defines the implementation of how to write to the property; the +\fIsetterScript\fR will become the body of a method taking a single argument, +\fIvalue\fR, defined on the class, if the kind of the property is such that +the property can be written to. The method will be named +\fB\fR, and will default to being a simple write +of the instance variable with the same name as the property (e.g., +.QW "\fBproperty\fR xyz" +will result in a method +.QW +being created). +.PP +Instances of the class that was created by \fBoo::configurable\fR will also +support \fBproperty\fR definitions; the semantics will be exactly as above +except that the properties will be defined on the instance alone. +.PP +Note that the property implementation methods that \fBproperty\fR defines +should not be private, as this makes them inaccessible from the implementation +of \fBconfigure\fR (by design; the property configuration mechanism is +intended for use mainly from outside a class, whereas a class may access +variables directly). The variables accessed by the default implementations of +the properties \fImay\fR be private, if so declared. +.SH "ADVANCED USAGE" +.PP +The configurable class system is comprised of several pieces. The +\fBoo::configurable\fR metaclass works by mixing in a class and setting +definition namespaces during object creation that provide the other bits and +pieces of machinery. The key pieces of the implementation are enumerated here +so that they can be used by other code: +.TP +\fBoo::configuresupport::configurable\fR +. +This is a class that provids the implementation of the \fBconfigure\fR method +(described above in \fBCONFIGURE METHOD\fR). +.TP +\fBoo::configuresupport::configurableclass\fR +. +This is a namespace that contains the definition dialect that provides the +\fBproperty\fR declaration for use in classes (i.e., via \fBoo::define\fR, and +class constructors under normal circumstances), as described above in +\fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR +command so that it may be used easily in user definition dialects. +.TP +. +\fBoo::configuresupport::configurableobject\fR +. +This is a namespace that contains the definition dialect that provides the +\fBproperty\fR declaration for use in instance objects (i.e., via +\fBoo::objdefine\fR, and the\fB self\R declaration in \fBoo::define), as +described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its +\fBproperty\fR command so that it may be used easily in user definition +dialects. +.PP +The underlying property discovery mechanism relies on four slots (see +\fBoo::define\fR for what that implies) that list the properties that can be +configured. These slots do not themselves impose any semantics on what the +slots mean other than that they have unique names, no important order, can be +inherited and discovered on classes and instances. +.PP +These slots, and their intended semantics, are: +.TP +\fBoo::configuresupport::readableproperties\fR +. +The set of properties of a class (not including those from its superclasses) +that may be read from when configuring an instance of the class. This slot can +also be read with the \fBinfo class property\fR command. +.TP +\fBoo::configuresupport::writableproperties\fR +. +The set of properties of a class (not including those from its superclasses) +that may be written to when configuring an instance of the class. This slot +can also be read with the \fBinfo class property\fR command. +.TP +\fBoo::configuresupport::objreadableproperties\fR +. +The set of properties of an object instance (not including those from its +classes) that may be read from when configuring the object. This slot can +also be read with the \fBinfo object property\fR command. +.TP +\fBoo::configuresupport::objwritableproperties\fR +. +The set of properties of an object instance (not including those from its +classes) that may be written to when configuring the object. This slot can +also be read with the \fBinfo object property\fR command. +.PP +Note that though these are slots, they are \fInot\fR in the standard +\fBoo::define\fR or \fBoo::objdefine\fR namespaces; in order to use them +inside a definition script, they need to be referred to by full name. This is +because they are intended to be building bricks of configurable property +system, and not directly used by normal user code. +.SS "IMPLEMENTATION NOTE" +.PP +The implementation of the \fBconfigure\fR method uses +\fBinfo object property\fR with the \fB\-all\fR option to discover what +properties it may manipulate. +.SH EXAMPLES +.PP +Here we create a simple configurable class and demonstrate how it can be +configured: +.PP +.CS +\fBoo::configurable\fR create Point { + \fBproperty\fR x y + constructor args { + my \fBconfigure\fR -x 0 -y 0 {*}$args + } + variable x y + method print {} { + puts "x=$x, y=$y" + } +} + +set pt [Point new -x 27] +$pt print; \fI# x=27, y=0\fR +$pt \fBconfigure\fR -y 42 +$pt print; \fI# x=27, y=42\fR +puts "distance from origin: [expr { + hypot([$pt \fBconfigure\fR -x], [$pt \fBconfigure\fR -y]) +}]"; \fI# distance from origin: 49.92995093127971\fR +puts [$pt \fBconfigure\fR] + \fI# -x 27 -y 42\fR +.CE +.PP +Such a configurable class can be extended by subclassing, though the subclass +needs to also be created by \fBoo::configurable\fR if it will use the +\fBproperty\fR definition: +.PP +.CS +\fBoo::configurable\fR create Point3D { + superclass Point + \fBproperty\fR z + constructor args { + next -z 0 {*}$args + } +} + +set pt2 [Point3D new -x 2 -y 3 -z 4] +puts [$pt2 \fBconfigure\fR] + \fI# -x 2 -y 3 -z 4\fR +.CE +.PP +Once you have a configurable class, you can also add instance properties to +it. (The backing variables for all properties start unset.) Note below that we +are using an unambiguous prefix of a property name when setting it; this is +supported for all properties though full names are normally recommended +because subclasses will not make an unambiguous prefix become ambiguous in +that case. +.PP +.CS +oo::objdefine $pt { + \fBproperty\fR color +} +$pt \fBconfigure\fR -c bisque +puts [$pt \fBconfigure\fR] + \fI# -color bisque -x 27 -y 42\fR +.CE +.PP +You can also do derived properties by making them read-only and supplying a +script that computes them. +.PP +.CS +\fBoo::configurable\fR create PointMk2 { + \fBproperty\fR x y + \fBproperty\fR distance -kind readable -get { + return [expr {hypot($x, $y)}] + } + variable x y + constructor args { + my \fBconfigure\fR -x 0 -y 0 {*}$args + } +} + +set pt3 [PointMk2 new -x 3 -y 4] +puts [$pt3 \fBconfigure\fR -distance] + \fI# 5.0\fR +$pt3 \fBconfigure\fR -distance 10 + \fI# ERROR: bad property "-distance": must be -x or -y\fR +.CE +.PP +Setters are used to validate the type of a property: +.PP +.CS +\fBoo::configurable\fR create PointMk3 { + \fBproperty\fR x -set { + if {![string is double -strict $value]} { + error "-x property must be a number" + } + set x $value + } + \fBproperty\fR y -set { + if {![string is double -strict $value]} { + error "-y property must be a number" + } + set y $value + } + variable x y + constructor args { + my \fBconfigure\fR -x 0 -y 0 {*}$args + } +} + +set pt4 [PointMk3 new] +puts [$pt4 \fBconfigure\fR] + \fI# -x 0 -y 0\fR +$pt4 \fBconfigure\fR -x 3 -y 4 +puts [$pt4 \fBconfigure\fR] + \fI# -x 3 -y 4\fR +$pt4 \fBconfigure\fR -x "obviously not a number" + \fI# ERROR: -x property must be a number\fR +.CE +.SH "SEE ALSO" +info(n), oo::class(n), oo::define(n) +.SH KEYWORDS +class, object, properties, configuration +.\" Local variables: +.\" mode: nroff +.\" fill-column: 78 +.\" End: diff --git a/doc/info.n b/doc/info.n index dc21ac1..ecf438b 100644 --- a/doc/info.n +++ b/doc/info.n @@ -492,6 +492,29 @@ be discovered with \fBinfo class forward\fR. This subcommand returns a list of all classes that have been mixed into the class named \fIclass\fR. .TP +\fBinfo class property\fI class\fR ?\fIoptions...\fR +.VS "TIP 558" +This subcommand returns a sorted list of properties defined on the class named +\fIclass\fR. The \fIoptions\fR define exactly which properties are returned: +.RS +.TP +\fB\-all\fR +. +With this option, the properties from the superclasses and mixins of the class +are also returned. +.TP +\fB\-readable\fR +. +This option (the default behavior) asks for the readable properties to be +returned. Only readable or writable properties are returned, not both. +.TP +\fB\-writable\fR +. +This option asks for the writable properties to be returned. Only readable or +writable properties are returned, not both. +.RE +.VE "TIP 558" +.TP \fBinfo class subclasses\fI class\fR ?\fIpattern\fR? . This subcommand returns a list of direct subclasses of class \fIclass\fR. If @@ -681,6 +704,30 @@ object named \fIobject\fR. This subcommand returns the name of the internal namespace of the object named \fIobject\fR. .TP +\fBinfo object property\fI object\fR ?\fIoptions...\fR +.VS "TIP 558" +This subcommand returns a sorted list of properties defined on the object +named \fIobject\fR. The \fIoptions\fR define exactly which properties are +returned: +.RS +.TP +\fB\-all\fR +. +With this option, the properties from the class, superclasses and mixins of +the object are also returned. +.TP +\fB\-readable\fR +. +This option (the default behavior) asks for the readable properties to be +returned. Only readable or writable properties are returned, not both. +.TP +\fB\-writable\fR +. +This option asks for the writable properties to be returned. Only readable or +writable properties are returned, not both. +.RE +.VE "TIP 558" +.TP \fBinfo object variables\fI object\fRR ?\fB\-private\fR? . This subcommand returns a list of all variables that have been declared for -- cgit v0.12 From c4f94adb460fd2389bbf4b3db9befcbfb97dae0b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2019 22:58:01 +0000 Subject: Other list-returning [info class] subcommands are plurals, so change property -> properties --- doc/configurable.n | 10 ++--- doc/info.n | 4 +- generic/tclOOInfo.c | 12 +++--- generic/tclOOScript.h | 40 ++++++++---------- tests/oo.test | 113 ++++++++++++++++++++++++++++---------------------- tools/tclOOScript.tcl | 42 +++++++++---------- 6 files changed, 113 insertions(+), 108 deletions(-) diff --git a/doc/configurable.n b/doc/configurable.n index f01f051..9a2a478 100644 --- a/doc/configurable.n +++ b/doc/configurable.n @@ -179,25 +179,25 @@ These slots, and their intended semantics, are: . The set of properties of a class (not including those from its superclasses) that may be read from when configuring an instance of the class. This slot can -also be read with the \fBinfo class property\fR command. +also be read with the \fBinfo class properties\fR command. .TP \fBoo::configuresupport::writableproperties\fR . The set of properties of a class (not including those from its superclasses) that may be written to when configuring an instance of the class. This slot -can also be read with the \fBinfo class property\fR command. +can also be read with the \fBinfo class properties\fR command. .TP \fBoo::configuresupport::objreadableproperties\fR . The set of properties of an object instance (not including those from its classes) that may be read from when configuring the object. This slot can -also be read with the \fBinfo object property\fR command. +also be read with the \fBinfo object properties\fR command. .TP \fBoo::configuresupport::objwritableproperties\fR . The set of properties of an object instance (not including those from its classes) that may be written to when configuring the object. This slot can -also be read with the \fBinfo object property\fR command. +also be read with the \fBinfo object properties\fR command. .PP Note that though these are slots, they are \fInot\fR in the standard \fBoo::define\fR or \fBoo::objdefine\fR namespaces; in order to use them @@ -207,7 +207,7 @@ system, and not directly used by normal user code. .SS "IMPLEMENTATION NOTE" .PP The implementation of the \fBconfigure\fR method uses -\fBinfo object property\fR with the \fB\-all\fR option to discover what +\fBinfo object properties\fR with the \fB\-all\fR option to discover what properties it may manipulate. .SH EXAMPLES .PP diff --git a/doc/info.n b/doc/info.n index ecf438b..cffaf49 100644 --- a/doc/info.n +++ b/doc/info.n @@ -492,7 +492,7 @@ be discovered with \fBinfo class forward\fR. This subcommand returns a list of all classes that have been mixed into the class named \fIclass\fR. .TP -\fBinfo class property\fI class\fR ?\fIoptions...\fR +\fBinfo class properties\fI class\fR ?\fIoptions...\fR .VS "TIP 558" This subcommand returns a sorted list of properties defined on the class named \fIclass\fR. The \fIoptions\fR define exactly which properties are returned: @@ -704,7 +704,7 @@ object named \fIobject\fR. This subcommand returns the name of the internal namespace of the object named \fIobject\fR. .TP -\fBinfo object property\fI object\fR ?\fIoptions...\fR +\fBinfo object properties\fI object\fR ?\fIoptions...\fR .VS "TIP 558" This subcommand returns a sorted list of properties defined on the object named \fIobject\fR. The \fIoptions\fR define exactly which properties are diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index ed44cc8..ffdcc10 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -64,7 +64,7 @@ static const EnsembleImplMap infoObjectCmds[] = { {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"property", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"properties", InfoObjectPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} @@ -86,7 +86,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"property", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"properties", InfoClassPropCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, @@ -1723,8 +1723,8 @@ InfoClassCallCmd( * * InfoClassPropCmd, InfoObjectPropCmd -- * - * Implements [info class property $clsName ?$option...?] and - * [info object property $objName ?$option...?] + * Implements [info class properties $clsName ?$option...?] and + * [info object properties $objName ?$option...?] * * ---------------------------------------------------------------------- */ @@ -1867,7 +1867,9 @@ InfoObjectPropCmd( * ---------------------------------------------------------------------- * * SortPropList -- - * Sort a list of names of properties. Simple support function. + * Sort a list of names of properties. Simple support function. Assumes + * that the list Tcl_Obj is unshared and doesn't have a string + * representation. * * ---------------------------------------------------------------------- */ diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index e8fd814..9782875 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -297,32 +297,24 @@ static const char *tclOOSetupScript = "\t\t\t\t\t\t}\n" "\t\t\t\t\t}\n" "\t\t\t\t}\n" +"\t\t\t\tset reader \n" +"\t\t\t\tset writer \n" "\t\t\t\tswitch $kind {\n" "\t\t\t\t\treadable {\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\t$writeslot -remove $realprop]\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\tmethod {} $getter]\n" +"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\twritable {\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\t$readslot -remove $realprop]\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\tmethod {value} $setter]\n" +"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\treadwrite {\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\tmethod {} $getter]\n" -"\t\t\t\t\t\tuplevel 2 [list \\\n" -"\t\t\t\t\t\t\t\tmethod {value} $setter]\n" +"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n" +"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t}\n" "\t\t\t}\n" @@ -333,6 +325,7 @@ static const char *tclOOSetupScript = "\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n" "\t\t\t}\n" +"\t\t\t::proc properties args {::tailcall property {*}$args}\n" "\t\t\t::namespace path ::oo::define\n" "\t\t\t::namespace export property\n" "\t\t}\n" @@ -342,12 +335,13 @@ static const char *tclOOSetupScript = "\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n" "\t\t\t}\n" +"\t\t\t::proc properties args {::tailcall property {*}$args}\n" "\t\t\t::namespace path ::oo::objdefine\n" "\t\t\t::namespace export property\n" "\t\t}\n" "\t\tproc ReadAll {object my} {\n" "\t\t\tset result {}\n" -"\t\t\tforeach prop [info object property $object -all -readable] {\n" +"\t\t\tforeach prop [info object properties $object -all -readable] {\n" "\t\t\t\ttry {\n" "\t\t\t\t\tdict set result $prop [$my ]\n" "\t\t\t\t} on error {msg opt} {\n" @@ -367,7 +361,7 @@ static const char *tclOOSetupScript = "\t\t\treturn $result\n" "\t\t}\n" "\t\tproc ReadOne {object my propertyName} {\n" -"\t\t\tset props [info object property $object -all -readable]\n" +"\t\t\tset props [info object properties $object -all -readable]\n" "\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" "\t\t\t\t\t-level 2 -errorcode [list \\\n" "\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName]] \\\n" @@ -390,7 +384,7 @@ static const char *tclOOSetupScript = "\t\t\treturn $value\n" "\t\t}\n" "\t\tproc WriteMany {object my setterMap} {\n" -"\t\t\tset props [info object property $object -all -writable]\n" +"\t\t\tset props [info object properties $object -all -writable]\n" "\t\t\tforeach {prop value} $setterMap {\n" "\t\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" "\t\t\t\t\t-level 2 -errorcode [list \\\n" diff --git a/tests/oo.test b/tests/oo.test index 631c84d..3fce886 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2424,7 +2424,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, property, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, properties, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -2643,7 +2643,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, property, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, properties, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { @@ -5455,15 +5455,15 @@ test oo-44.1 {TIP 558: properties: core support} -setup { set result {} } -body { oo::class create c {superclass parent} - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::readableproperties -set a b c - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::readableproperties -set f e d - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::readableproperties -set a a a - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::readableproperties -set - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] } -cleanup { parent destroy } -result {{} {} {a b c} {} {d e f} {} a {} {} {}} @@ -5473,15 +5473,15 @@ test oo-44.2 {TIP 558: properties: core support} -setup { set result {} } -body { oo::class create c {superclass parent} - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::readableproperties -set a b c - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::readableproperties -set f e d - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::readableproperties -set a a a - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::readableproperties -set - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] } -cleanup { parent destroy } -result {{} {} {a b c} {} {d e f} {} a {} {} {}} @@ -5491,15 +5491,15 @@ test oo-44.3 {TIP 558: properties: core support} -setup { set result {} } -body { oo::class create c {superclass parent} - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::writableproperties -set a b c - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::writableproperties -set f e d - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::writableproperties -set a a a - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] oo::define c ::oo::configuresupport::writableproperties -set - lappend result [info class property c] [info class property c -writable] + lappend result [info class properties c] [info class properties c -writable] } -cleanup { parent destroy } -result {{} {} {} {a b c} {} {d e f} {} a {} {}} @@ -5509,15 +5509,15 @@ test oo-44.4 {TIP 558: properties: core support} -setup { set result {} } -body { oo::class create c {superclass parent} - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::writableproperties -set a b c - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::writableproperties -set f e d - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::writableproperties -set a a a - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] oo::define c ::oo::configuresupport::writableproperties -set - lappend result [info class property c -all] [info class property c -writable -all] + lappend result [info class properties c -all] [info class properties c -writable -all] } -cleanup { parent destroy } -result {{} {} {} {a b c} {} {d e f} {} a {} {}} @@ -5528,20 +5528,20 @@ test oo-44.5 {TIP 558: properties: core support} -setup { } -body { oo::class create c {superclass parent} oo::class create d {superclass c} - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::readableproperties -set a b c oo::define d ::oo::configuresupport::readableproperties -set x y z - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::readableproperties -set f e d oo::define d ::oo::configuresupport::readableproperties -set r p q - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::readableproperties -set a a h oo::define d ::oo::configuresupport::readableproperties -set g h g - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::readableproperties -set - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define d ::oo::configuresupport::readableproperties -set - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] } -cleanup { parent destroy } -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}} @@ -5552,20 +5552,20 @@ test oo-44.6 {TIP 558: properties: core support} -setup { } -body { oo::class create c {superclass parent} oo::class create d {superclass c} - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::writableproperties -set a b c oo::define d ::oo::configuresupport::writableproperties -set x y z - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::writableproperties -set f e d oo::define d ::oo::configuresupport::writableproperties -set r p q - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::writableproperties -set a a h oo::define d ::oo::configuresupport::writableproperties -set g h g - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define c ::oo::configuresupport::writableproperties -set - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] oo::define d ::oo::configuresupport::writableproperties -set - lappend result [info class property d -all] [info class property d -writable -all] + lappend result [info class properties d -all] [info class properties d -writable -all] } -cleanup { parent destroy } -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}} @@ -5576,15 +5576,15 @@ test oo-44.7 {TIP 558: properties: core support} -setup { } -body { oo::class create c {superclass parent} c create o - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objreadableproperties -set - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] } -cleanup { parent destroy } -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}} @@ -5595,15 +5595,15 @@ test oo-44.8 {TIP 558: properties: core support} -setup { } -body { oo::class create c {superclass parent} c create o - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] oo::objdefine o ::oo::configuresupport::objwritableproperties -set - lappend result [info object property o] [info object property o -writable] + lappend result [info object properties o] [info object properties o -writable] } -cleanup { parent destroy } -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}} @@ -5615,13 +5615,13 @@ test oo-44.9 {TIP 558: properties: core support} -setup { oo::class create c {superclass parent} oo::class create d {superclass c} d create o - lappend result [info object property o -all] [info object property o -writable -all] + lappend result [info object properties o -all] [info object properties o -writable -all] oo::define c ::oo::configuresupport::readableproperties -set a b oo::define d ::oo::configuresupport::readableproperties -set c d oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f - lappend result [info object property o -all] [info object property o -writable -all] + lappend result [info object properties o -all] [info object properties o -writable -all] oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e - lappend result [info object property o -all] [info object property o -writable -all] + lappend result [info object properties o -all] [info object properties o -writable -all] } -cleanup { parent destroy } -result {{} {} {a b c d e f} {} {a b c d e f} {}} @@ -5633,13 +5633,13 @@ test oo-44.10 {TIP 558: properties: core support} -setup { oo::class create c {superclass parent} oo::class create d {superclass c} d create o - lappend result [info object property o -all] [info object property o -writable -all] + lappend result [info object properties o -all] [info object properties o -writable -all] oo::define c ::oo::configuresupport::writableproperties -set a b oo::define d ::oo::configuresupport::writableproperties -set c d oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f - lappend result [info object property o -all] [info object property o -writable -all] + lappend result [info object properties o -all] [info object properties o -writable -all] oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e - lappend result [info object property o -all] [info object property o -writable -all] + lappend result [info object properties o -all] [info object properties o -writable -all] } -cleanup { parent destroy } -result {{} {} {} {a b c d e f} {} {a b c d e f}} @@ -6111,6 +6111,19 @@ test oo-46.22 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok +test oo-46.23 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + private property var + } + Point create pt + pt configure -var ok + pt configure -var +} -cleanup { + parent destroy +} -result ok test oo-47.1 {TIP 558: properties: error details} -setup { oo::class create parent diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 56a7bf8..095a3ad 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -528,32 +528,24 @@ } # Install the option + set reader + set writer switch $kind { readable { - uplevel 2 [list \ - $readslot -append $realprop] - uplevel 2 [list \ - $writeslot -remove $realprop] - uplevel 2 [list \ - method {} $getter] + uplevel 2 [list $readslot -append $realprop] + uplevel 2 [list $writeslot -remove $realprop] + uplevel 2 [list method $reader -unexport {} $getter] } writable { - uplevel 2 [list \ - $readslot -remove $realprop] - uplevel 2 [list \ - $writeslot -append $realprop] - uplevel 2 [list \ - method {value} $setter] + uplevel 2 [list $readslot -remove $realprop] + uplevel 2 [list $writeslot -append $realprop] + uplevel 2 [list method $writer -unexport {value} $setter] } readwrite { - uplevel 2 [list \ - $readslot -append $realprop] - uplevel 2 [list \ - $writeslot -append $realprop] - uplevel 2 [list \ - method {} $getter] - uplevel 2 [list \ - method {value} $setter] + uplevel 2 [list $readslot -append $realprop] + uplevel 2 [list $writeslot -append $realprop] + uplevel 2 [list method $reader -unexport {} $getter] + uplevel 2 [list method $writer -unexport {value} $setter] } } } @@ -575,6 +567,8 @@ ::oo::configuresupport::readableproperties \ ::oo::configuresupport::writableproperties {*}$args } + # Plural alias just in case; deliberately NOT documented! + ::proc properties args {::tailcall property {*}$args} ::namespace path ::oo::define ::namespace export property } @@ -585,6 +579,8 @@ ::oo::configuresupport::objreadableproperties \ ::oo::configuresupport::objwritableproperties {*}$args } + # Plural alias just in case; deliberately NOT documented! + ::proc properties args {::tailcall property {*}$args} ::namespace path ::oo::objdefine ::namespace export property } @@ -599,7 +595,7 @@ proc ReadAll {object my} { set result {} - foreach prop [info object property $object -all -readable] { + foreach prop [info object properties $object -all -readable] { try { dict set result $prop [$my ] } on error {msg opt} { @@ -629,7 +625,7 @@ # ------------------------------------------------------------------ proc ReadOne {object my propertyName} { - set props [info object property $object -all -readable] + set props [info object properties $object -all -readable] set prop [prefix match -message "property" -error [list\ -level 2 -errorcode [list \ TCL LOOKUP INDEX property $propertyName]] \ @@ -661,7 +657,7 @@ # ------------------------------------------------------------------ proc WriteMany {object my setterMap} { - set props [info object property $object -all -writable] + set props [info object properties $object -all -writable] foreach {prop value} $setterMap { set prop [prefix match -message "property" -error [list\ -level 2 -errorcode [list \ -- cgit v0.12 From 995eed36fdc1c5eba5c874e149f17e213a261e7c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Dec 2019 23:25:58 +0000 Subject: Better error messages when a property has the wrong kind for the type of access desired --- generic/tclOOScript.h | 30 ++++++++++++++++++++++-------- tests/oo.test | 9 +++++---- tools/tclOOScript.tcl | 32 +++++++++++++++++++++++--------- 3 files changed, 50 insertions(+), 21 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 9782875..ed8d2dd 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -362,10 +362,17 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\tproc ReadOne {object my propertyName} {\n" "\t\t\tset props [info object properties $object -all -readable]\n" -"\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" -"\t\t\t\t\t-level 2 -errorcode [list \\\n" -"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName]] \\\n" -"\t\t\t\t\t\t $props $propertyName]\n" +"\t\t\ttry {\n" +"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n" +"\t\t\t} on error {msg} {\n" +"\t\t\t\tcatch {\n" +"\t\t\t\t\tset wps [info object properties $object -all -writable]\n" +"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n" +"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n" +"\t\t\t\t}\n" +"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n" +"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n" +"\t\t\t}\n" "\t\t\ttry {\n" "\t\t\t\tset value [$my ]\n" "\t\t\t} on error {msg opt} {\n" @@ -386,10 +393,17 @@ static const char *tclOOSetupScript = "\t\tproc WriteMany {object my setterMap} {\n" "\t\t\tset props [info object properties $object -all -writable]\n" "\t\t\tforeach {prop value} $setterMap {\n" -"\t\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" -"\t\t\t\t\t-level 2 -errorcode [list \\\n" -"\t\t\t\t\t\tTCL LOOKUP INDEX property $prop]] \\\n" -"\t\t\t\t\t\t\t $props $prop]\n" +"\t\t\t\ttry {\n" +"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n" +"\t\t\t\t} on error {msg} {\n" +"\t\t\t\t\tcatch {\n" +"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n" +"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n" +"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n" +"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n" +"\t\t\t\t}\n" "\t\t\t\ttry {\n" "\t\t\t\t\t$my $value\n" "\t\t\t\t} on error {msg opt} {\n" diff --git a/tests/oo.test b/tests/oo.test index 3fce886..e869a3c 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5773,7 +5773,7 @@ test oo-45.7 {TIP 558: properties: configurable class system} -setup { list [p configure -y ok] [catch {p configure -y} msg] $msg } -cleanup { parent destroy -} -result {{} 1 {bad property "-y": must be -x}} +} -result {{} 1 {property "-y" is write only}} test oo-45.8 {TIP 558: properties: configurable class system} -setup { oo::class create parent unset -nocomplain msg @@ -5790,7 +5790,7 @@ test oo-45.8 {TIP 558: properties: configurable class system} -setup { list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg } -cleanup { parent destroy -} -result {{-x 0 -y 123} 123 1 {bad property "-y": must be -x}} +} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}} test oo-46.1 {ITP 558: properties: declaration semantics} -setup { oo::class create parent @@ -5946,17 +5946,18 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup { variable xy property x -kind readable -get {return $xy} property x -kind writable -set {set xy $value} - property y } Point create pt list [catch { pt configure -x ok } msg] $msg [catch { pt configure -x + } msg] $msg [catch { + pt configure -y 1 } msg] $msg } -cleanup { parent destroy -} -result {0 {} 1 {bad property "-x": must be -y}} +} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}} test oo-46.12 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 095a3ad..12288e4 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -4,7 +4,7 @@ # that the code can be definitely run even in safe interpreters; TclOO's # core setup is safe. # -# Copyright (c) 2012-2018 Donal K. Fellows +# Copyright (c) 2012-2019 Donal K. Fellows # Copyright (c) 2013 Andreas Kupries # Copyright (c) 2017 Gerald Lester # @@ -626,10 +626,17 @@ proc ReadOne {object my propertyName} { set props [info object properties $object -all -readable] - set prop [prefix match -message "property" -error [list\ - -level 2 -errorcode [list \ - TCL LOOKUP INDEX property $propertyName]] \ - $props $propertyName] + try { + set prop [prefix match -message "property" $props $propertyName] + } on error {msg} { + catch { + set wps [info object properties $object -all -writable] + set wprop [prefix match $wps $propertyName] + set msg "property \"$wprop\" is write only" + } + return -code error -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $propertyName] $msg + } try { set value [$my ] } on error {msg opt} { @@ -659,10 +666,17 @@ proc WriteMany {object my setterMap} { set props [info object properties $object -all -writable] foreach {prop value} $setterMap { - set prop [prefix match -message "property" -error [list\ - -level 2 -errorcode [list \ - TCL LOOKUP INDEX property $prop]] \ - $props $prop] + try { + set prop [prefix match -message "property" $props $prop] + } on error {msg} { + catch { + set rps [info object properties $object -all -readable] + set rprop [prefix match $rps $prop] + set msg "property \"$rprop\" is read only" + } + return -code error -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $prop] $msg + } try { $my $value } on error {msg opt} { -- cgit v0.12 From b308bd97e6cdee90b11f3409a485253c414bbac0 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jan 2020 16:01:36 +0000 Subject: Check for another tricky edge case --- generic/tclOOScript.h | 5 +++++ tests/oo.test | 58 ++++++++++++++++++++++++++++++--------------------- tools/tclOOScript.tcl | 5 +++++ 3 files changed, 44 insertions(+), 24 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index ed8d2dd..ae58ccb 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -258,6 +258,11 @@ static const char *tclOOSetupScript = "\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" "\t\t\t\t\t\t\"bad property name \\\"$prop\\\"; must not begin with -\"\n" "\t\t\t\t}\n" +"\t\t\t\tif {$prop ne [list $prop]} {\n" +"\t\t\t\t\treturn -code error -level 2 \\\n" +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\"; must be a simple word\"\n" +"\t\t\t\t}\n" "\t\t\t\tset realprop [string cat \"-\" $prop]\n" "\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n" "\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n" diff --git a/tests/oo.test b/tests/oo.test index e869a3c..673b941 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5792,7 +5792,7 @@ test oo-45.8 {TIP 558: properties: configurable class system} -setup { parent destroy } -result {{-x 0 -y 123} 123 1 {property "-y" is read only}} -test oo-46.1 {ITP 558: properties: declaration semantics} -setup { +test oo-46.1 {TIP 558: properties: declaration semantics} -setup { oo::class create parent unset -nocomplain result set result {} @@ -5816,7 +5816,7 @@ test oo-46.1 {ITP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result {{set 5} get {>15 15 15<}} -test oo-46.2 {ITP 558: properties: declaration semantics} -setup { +test oo-46.2 {TIP 558: properties: declaration semantics} -setup { oo::class create parent unset -nocomplain result set result {} @@ -5840,7 +5840,7 @@ test oo-46.2 {ITP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result {{set 5} get {>15 15 15<} 15} -test oo-46.2 {TIP 558: properties: declaration semantics} -setup { +test oo-46.3 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5851,7 +5851,17 @@ test oo-46.2 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {bad property name "-x"; must not begin with -} -test oo-46.3 {TIP 558: properties: declaration semantics} -setup { +test oo-46.4 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property "x y" + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x y"; must be a simple word} +test oo-46.5 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5861,7 +5871,7 @@ test oo-46.3 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {missing body to go with -get option} -test oo-46.4 {TIP 558: properties: declaration semantics} -setup { +test oo-46.6 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5871,7 +5881,7 @@ test oo-46.4 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {missing body to go with -set option} -test oo-46.5 {TIP 558: properties: declaration semantics} -setup { +test oo-46.7 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5881,7 +5891,7 @@ test oo-46.5 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {missing kind value to go with -kind option} -test oo-46.6 {TIP 558: properties: declaration semantics} -setup { +test oo-46.8 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5891,7 +5901,7 @@ test oo-46.6 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {missing body to go with -set option} -test oo-46.7 {TIP 558: properties: declaration semantics} -setup { +test oo-46.9 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5902,7 +5912,7 @@ test oo-46.7 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.8 {TIP 558: properties: declaration semantics} -setup { +test oo-46.10 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5912,7 +5922,7 @@ test oo-46.8 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {bad kind "gorp": must be readable, readwrite, or writable} -test oo-46.9 {TIP 558: properties: declaration semantics} -setup { +test oo-46.11 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5923,7 +5933,7 @@ test oo-46.9 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.10 {TIP 558: properties: declaration semantics} -setup { +test oo-46.12 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5937,7 +5947,7 @@ test oo-46.10 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.11 {TIP 558: properties: declaration semantics} -setup { +test oo-46.13 {TIP 558: properties: declaration semantics} -setup { oo::class create parent unset -nocomplain msg } -body { @@ -5958,7 +5968,7 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}} -test oo-46.12 {TIP 558: properties: declaration semantics} -setup { +test oo-46.14 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5972,7 +5982,7 @@ test oo-46.12 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property getter for -x did a break} -test oo-46.13 {TIP 558: properties: declaration semantics} -setup { +test oo-46.15 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5986,7 +5996,7 @@ test oo-46.13 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property getter for -x did a break} -test oo-46.14 {TIP 558: properties: declaration semantics} -setup { +test oo-46.16 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6000,7 +6010,7 @@ test oo-46.14 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result boo -test oo-46.15 {TIP 558: properties: declaration semantics} -setup { +test oo-46.17 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6014,7 +6024,7 @@ test oo-46.15 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result boo -test oo-46.16 {TIP 558: properties: declaration semantics} -setup { +test oo-46.18 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6028,7 +6038,7 @@ test oo-46.16 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property getter for -x did a continue} -test oo-46.17 {TIP 558: properties: declaration semantics} -setup { +test oo-46.19 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6042,7 +6052,7 @@ test oo-46.17 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.18 {TIP 558: properties: declaration semantics} -setup { +test oo-46.20 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6056,7 +6066,7 @@ test oo-46.18 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.19 {TIP 558: properties: declaration semantics} -setup { +test oo-46.21 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6070,7 +6080,7 @@ test oo-46.19 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property setter for -x did a break} -test oo-46.20 {TIP 558: properties: declaration semantics} -setup { +test oo-46.22 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6084,7 +6094,7 @@ test oo-46.20 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property setter for -x did a continue} -test oo-46.21 {TIP 558: properties: declaration semantics} -setup { +test oo-46.23 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6098,7 +6108,7 @@ test oo-46.21 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result boo -test oo-46.22 {TIP 558: properties: declaration semantics} -setup { +test oo-46.24 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6112,7 +6122,7 @@ test oo-46.22 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.23 {TIP 558: properties: declaration semantics} -setup { +test oo-46.25 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 12288e4..e10eda2 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -485,6 +485,11 @@ -errorcode {TCLOO PROPERTY_FORMAT} \ "bad property name \"$prop\"; must not begin with -" } + if {$prop ne [list $prop]} { + return -code error -level 2 \ + -errorcode {TCLOO PROPERTY_FORMAT} \ + "bad property name \"$prop\"; must be a simple word" + } set realprop [string cat "-" $prop] set getter [format {::set [my varname %s]} $prop] set setter [format {::set [my varname %s] $value} $prop] -- cgit v0.12 From 8249e877dffdca52ba20e0ffebdc9c7bd37c30ae Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jan 2020 16:46:55 +0000 Subject: More error cases --- generic/tclOOScript.h | 14 ++++++++-- tests/oo.test | 76 +++++++++++++++++++++++++++++++++++---------------- tools/tclOOScript.tcl | 14 ++++++++-- 3 files changed, 77 insertions(+), 27 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index ae58ccb..2b61866 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -256,12 +256,22 @@ static const char *tclOOSetupScript = "\t\t\t\tif {[string match \"-*\" $prop]} {\n" "\t\t\t\t\treturn -code error -level 2 \\\n" "\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" -"\t\t\t\t\t\t\"bad property name \\\"$prop\\\"; must not begin with -\"\n" +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n" "\t\t\t\t}\n" "\t\t\t\tif {$prop ne [list $prop]} {\n" "\t\t\t\t\treturn -code error -level 2 \\\n" "\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" -"\t\t\t\t\t\t\"bad property name \\\"$prop\\\"; must be a simple word\"\n" +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n" +"\t\t\t\t}\n" +"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n" +"\t\t\t\t\treturn -code error -level 2 \\\n" +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n" +"\t\t\t\t}\n" +"\t\t\t\tif {[string match {*[()]*} $prop]} {\n" +"\t\t\t\t\treturn -code error -level 2 \\\n" +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n" +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n" "\t\t\t\t}\n" "\t\t\t\tset realprop [string cat \"-\" $prop]\n" "\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n" diff --git a/tests/oo.test b/tests/oo.test index 673b941..4d28794 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5850,7 +5850,7 @@ test oo-46.3 {TIP 558: properties: declaration semantics} -setup { } } -returnCodes error -cleanup { parent destroy -} -result {bad property name "-x"; must not begin with -} +} -result {bad property name "-x": must not begin with -} test oo-46.4 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { @@ -5860,18 +5860,48 @@ test oo-46.4 {TIP 558: properties: declaration semantics} -setup { } } -returnCodes error -cleanup { parent destroy -} -result {bad property name "x y"; must be a simple word} +} -result {bad property name "x y": must be a simple word} test oo-46.5 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} oo::define Point { + property ::x + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "::x": must not contain namespace separators} +test oo-46.6 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x( + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x(": must not contain parentheses} +test oo-46.7 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x) + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x)": must not contain parentheses} +test oo-46.8 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { property x -get } } -returnCodes error -cleanup { parent destroy } -result {missing body to go with -get option} -test oo-46.6 {TIP 558: properties: declaration semantics} -setup { +test oo-46.9 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5881,7 +5911,7 @@ test oo-46.6 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {missing body to go with -set option} -test oo-46.7 {TIP 558: properties: declaration semantics} -setup { +test oo-46.10 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5891,7 +5921,7 @@ test oo-46.7 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {missing kind value to go with -kind option} -test oo-46.8 {TIP 558: properties: declaration semantics} -setup { +test oo-46.11 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point {superclass parent} @@ -5901,7 +5931,7 @@ test oo-46.8 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {missing body to go with -set option} -test oo-46.9 {TIP 558: properties: declaration semantics} -setup { +test oo-46.12 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5912,7 +5942,7 @@ test oo-46.9 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.10 {TIP 558: properties: declaration semantics} -setup { +test oo-46.13 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5922,7 +5952,7 @@ test oo-46.10 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {bad kind "gorp": must be readable, readwrite, or writable} -test oo-46.11 {TIP 558: properties: declaration semantics} -setup { +test oo-46.14 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5933,7 +5963,7 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.12 {TIP 558: properties: declaration semantics} -setup { +test oo-46.15 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5947,7 +5977,7 @@ test oo-46.12 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.13 {TIP 558: properties: declaration semantics} -setup { +test oo-46.16 {TIP 558: properties: declaration semantics} -setup { oo::class create parent unset -nocomplain msg } -body { @@ -5968,7 +5998,7 @@ test oo-46.13 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}} -test oo-46.14 {TIP 558: properties: declaration semantics} -setup { +test oo-46.17 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5982,7 +6012,7 @@ test oo-46.14 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property getter for -x did a break} -test oo-46.15 {TIP 558: properties: declaration semantics} -setup { +test oo-46.18 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -5996,7 +6026,7 @@ test oo-46.15 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property getter for -x did a break} -test oo-46.16 {TIP 558: properties: declaration semantics} -setup { +test oo-46.19 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6010,7 +6040,7 @@ test oo-46.16 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result boo -test oo-46.17 {TIP 558: properties: declaration semantics} -setup { +test oo-46.20 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6024,7 +6054,7 @@ test oo-46.17 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result boo -test oo-46.18 {TIP 558: properties: declaration semantics} -setup { +test oo-46.21 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6038,7 +6068,7 @@ test oo-46.18 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property getter for -x did a continue} -test oo-46.19 {TIP 558: properties: declaration semantics} -setup { +test oo-46.22 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6052,7 +6082,7 @@ test oo-46.19 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.20 {TIP 558: properties: declaration semantics} -setup { +test oo-46.23 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6066,7 +6096,7 @@ test oo-46.20 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.21 {TIP 558: properties: declaration semantics} -setup { +test oo-46.24 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6080,7 +6110,7 @@ test oo-46.21 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property setter for -x did a break} -test oo-46.22 {TIP 558: properties: declaration semantics} -setup { +test oo-46.25 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6094,7 +6124,7 @@ test oo-46.22 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result {property setter for -x did a continue} -test oo-46.23 {TIP 558: properties: declaration semantics} -setup { +test oo-46.26 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6108,7 +6138,7 @@ test oo-46.23 {TIP 558: properties: declaration semantics} -setup { } -returnCodes error -cleanup { parent destroy } -result boo -test oo-46.24 {TIP 558: properties: declaration semantics} -setup { +test oo-46.27 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6122,7 +6152,7 @@ test oo-46.24 {TIP 558: properties: declaration semantics} -setup { } -cleanup { parent destroy } -result ok -test oo-46.25 {TIP 558: properties: declaration semantics} -setup { +test oo-46.28 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { oo::configurable create Point { @@ -6145,7 +6175,7 @@ test oo-47.1 {TIP 558: properties: error details} -setup { [dict get $opt -errorinfo] [dict get $opt -errorcode] } -cleanup { parent destroy -} -result {1 {bad property name "-x"; must not begin with - +} -result {1 {bad property name "-x": must not begin with - while executing "property -x" (in definition script for class "::Point" line 1) diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index e10eda2..e918787 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -483,12 +483,22 @@ if {[string match "-*" $prop]} { return -code error -level 2 \ -errorcode {TCLOO PROPERTY_FORMAT} \ - "bad property name \"$prop\"; must not begin with -" + "bad property name \"$prop\": must not begin with -" } if {$prop ne [list $prop]} { return -code error -level 2 \ -errorcode {TCLOO PROPERTY_FORMAT} \ - "bad property name \"$prop\"; must be a simple word" + "bad property name \"$prop\": must be a simple word" + } + if {[string first "::" $prop] != -1} { + return -code error -level 2 \ + -errorcode {TCLOO PROPERTY_FORMAT} \ + "bad property name \"$prop\": must not contain namespace separators" + } + if {[string match {*[()]*} $prop]} { + return -code error -level 2 \ + -errorcode {TCLOO PROPERTY_FORMAT} \ + "bad property name \"$prop\": must not contain parentheses" } set realprop [string cat "-" $prop] set getter [format {::set [my varname %s]} $prop] -- cgit v0.12 From 743e0e4e1a39cf24723ff9390322f904113e770b Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 1 Jan 2020 16:57:08 +0000 Subject: Move the TIP 558 tests into their own file --- tests/oo.test | 840 ---------------------------------------------------- tests/ooProp.test | 862 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 862 insertions(+), 840 deletions(-) create mode 100644 tests/ooProp.test diff --git a/tests/oo.test b/tests/oo.test index 4d28794..1ec33e7 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5448,846 +5448,6 @@ test oo-43.13 {TIP 524: definition namespace control: user-level introspection} parent destroy namespace delete foodef } -result {{} {} ::foodef {} {}} - -test oo-44.1 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::readableproperties -set a b c - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::readableproperties -set f e d - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::readableproperties -set a a a - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::readableproperties -set - lappend result [info class properties c] [info class properties c -writable] -} -cleanup { - parent destroy -} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} -test oo-44.2 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set a b c - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set f e d - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set a a a - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set - lappend result [info class properties c -all] [info class properties c -writable -all] -} -cleanup { - parent destroy -} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} -test oo-44.3 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::writableproperties -set a b c - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::writableproperties -set f e d - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::writableproperties -set a a a - lappend result [info class properties c] [info class properties c -writable] - oo::define c ::oo::configuresupport::writableproperties -set - lappend result [info class properties c] [info class properties c -writable] -} -cleanup { - parent destroy -} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} -test oo-44.4 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set a b c - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set f e d - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set a a a - lappend result [info class properties c -all] [info class properties c -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set - lappend result [info class properties c -all] [info class properties c -writable -all] -} -cleanup { - parent destroy -} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} -test oo-44.5 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - oo::class create d {superclass c} - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set a b c - oo::define d ::oo::configuresupport::readableproperties -set x y z - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set f e d - oo::define d ::oo::configuresupport::readableproperties -set r p q - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set a a h - oo::define d ::oo::configuresupport::readableproperties -set g h g - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define d ::oo::configuresupport::readableproperties -set - lappend result [info class properties d -all] [info class properties d -writable -all] -} -cleanup { - parent destroy -} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}} -test oo-44.6 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - oo::class create d {superclass c} - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set a b c - oo::define d ::oo::configuresupport::writableproperties -set x y z - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set f e d - oo::define d ::oo::configuresupport::writableproperties -set r p q - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set a a h - oo::define d ::oo::configuresupport::writableproperties -set g h g - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set - lappend result [info class properties d -all] [info class properties d -writable -all] - oo::define d ::oo::configuresupport::writableproperties -set - lappend result [info class properties d -all] [info class properties d -writable -all] -} -cleanup { - parent destroy -} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}} -test oo-44.7 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - c create o - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objreadableproperties -set - lappend result [info object properties o] [info object properties o -writable] -} -cleanup { - parent destroy -} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}} -test oo-44.8 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - c create o - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h - lappend result [info object properties o] [info object properties o -writable] - oo::objdefine o ::oo::configuresupport::objwritableproperties -set - lappend result [info object properties o] [info object properties o -writable] -} -cleanup { - parent destroy -} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}} -test oo-44.9 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - oo::class create d {superclass c} - d create o - lappend result [info object properties o -all] [info object properties o -writable -all] - oo::define c ::oo::configuresupport::readableproperties -set a b - oo::define d ::oo::configuresupport::readableproperties -set c d - oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f - lappend result [info object properties o -all] [info object properties o -writable -all] - oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e - lappend result [info object properties o -all] [info object properties o -writable -all] -} -cleanup { - parent destroy -} -result {{} {} {a b c d e f} {} {a b c d e f} {}} -test oo-44.10 {TIP 558: properties: core support} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::class create c {superclass parent} - oo::class create d {superclass c} - d create o - lappend result [info object properties o -all] [info object properties o -writable -all] - oo::define c ::oo::configuresupport::writableproperties -set a b - oo::define d ::oo::configuresupport::writableproperties -set c d - oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f - lappend result [info object properties o -all] [info object properties o -writable -all] - oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e - lappend result [info object properties o -all] [info object properties o -writable -all] -} -cleanup { - parent destroy -} -result {{} {} {} {a b c d e f} {} {a b c d e f}} - -test oo-45.1 {TIP 558: properties: configurable class system} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::configurable create Point { - superclass parent - property x y - constructor args { - my configure -x 0 -y 0 {*}$args - } - variable x y - method report {} { - lappend ::result "x=$x, y=$y" - } - } - set pt [Point new -x 3] - $pt report - $pt configure -y 4 - $pt report - lappend result [$pt configure -x],[$pt configure -y] [$pt configure] -} -cleanup { - parent destroy -} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}} -test oo-45.2 {TIP 558: properties: configurable class system} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x y - constructor args { - my configure -x 0 -y 0 {*}$args - } - } - oo::configurable create 3DPoint { - superclass Point - property z - constructor args { - next -z 0 {*}$args - } - } - set pt [3DPoint new -x 3 -y 4 -z 5] - list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ - [$pt configure] -} -cleanup { - parent destroy -} -result {3,4,5 {-x 3 -y 4 -z 5}} -test oo-45.3 {TIP 558: properties: configurable class system} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x y - constructor args { - my configure -x 0 -y 0 {*}$args - } - } - set pt [Point new -x 3 -y 4] - oo::objdefine $pt property z - $pt configure -z 5 - list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ - [$pt configure] -} -cleanup { - parent destroy -} -result {3,4,5 {-x 3 -y 4 -z 5}} -test oo-45.4 {TIP 558: properties: configurable class system} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x y - constructor args { - my configure -x 0 -y 0 {*}$args - } - } - [Point new] configure gorp -} -returnCodes error -cleanup { - parent destroy -} -result {bad property "gorp": must be -x or -y} -test oo-45.5 {TIP 558: properties: configurable class system} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x y - constructor args { - my configure -x 0 -y 0 {*}$args - } - } - oo::configurable create 3DPoint { - superclass Point - property z - constructor args { - next -z 0 {*}$args - } - } - [3DPoint new] configure gorp -} -returnCodes error -cleanup { - parent destroy -} -result {bad property "gorp": must be -x, -y, or -z} -test oo-45.6 {TIP 558: properties: configurable class system} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x y - constructor args { - my configure -x 0 -y 0 {*}$args - } - } - [Point create p] configure -x 1 -y -} -returnCodes error -cleanup { - parent destroy -} -result {wrong # args: should be "::p configure ?-option value ...?"} -test oo-45.7 {TIP 558: properties: configurable class system} -setup { - oo::class create parent - unset -nocomplain msg -} -body { - oo::configurable create Point { - superclass parent - property x y -kind writable - constructor args { - my configure -x 0 -y 0 {*}$args - } - } - Point create p - list [p configure -y ok] [catch {p configure -y} msg] $msg -} -cleanup { - parent destroy -} -result {{} 1 {property "-y" is write only}} -test oo-45.8 {TIP 558: properties: configurable class system} -setup { - oo::class create parent - unset -nocomplain msg -} -body { - oo::configurable create Point { - superclass parent - property x y -kind readable - constructor args { - my configure -x 0 {*}$args - variable y 123 - } - } - Point create p - list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg -} -cleanup { - parent destroy -} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}} - -test oo-46.1 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - variable xyz - property x -get { - global result - lappend result "get" - return [lrepeat 3 $xyz] - } -set { - global result - lappend result [list set $value] - set xyz [expr {$value * 3}] - } - } - Point create pt - pt configure -x 5 - lappend result >[pt configure -x]< -} -cleanup { - parent destroy -} -result {{set 5} get {>15 15 15<}} -test oo-46.2 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent - unset -nocomplain result - set result {} -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - variable xyz - property x -get { - global result - lappend result "get" - return [lrepeat 3 $xyz] - } -set { - global result - lappend result [list set $value] - set xyz [expr {$value * 3}] - } y -kind readable -get {return $xyz} - } - Point create pt - pt configure -x 5 - lappend result >[pt configure -x]< [pt configure -y] -} -cleanup { - parent destroy -} -result {{set 5} get {>15 15 15<} 15} -test oo-46.3 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - variable xyz - property -x -get {return $xyz} - } -} -returnCodes error -cleanup { - parent destroy -} -result {bad property name "-x": must not begin with -} -test oo-46.4 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property "x y" - } -} -returnCodes error -cleanup { - parent destroy -} -result {bad property name "x y": must be a simple word} -test oo-46.5 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property ::x - } -} -returnCodes error -cleanup { - parent destroy -} -result {bad property name "::x": must not contain namespace separators} -test oo-46.6 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property x( - } -} -returnCodes error -cleanup { - parent destroy -} -result {bad property name "x(": must not contain parentheses} -test oo-46.7 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property x) - } -} -returnCodes error -cleanup { - parent destroy -} -result {bad property name "x)": must not contain parentheses} -test oo-46.8 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property x -get - } -} -returnCodes error -cleanup { - parent destroy -} -result {missing body to go with -get option} -test oo-46.9 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property x -set - } -} -returnCodes error -cleanup { - parent destroy -} -result {missing body to go with -set option} -test oo-46.10 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property x -kind - } -} -returnCodes error -cleanup { - parent destroy -} -result {missing kind value to go with -kind option} -test oo-46.11 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point {superclass parent} - oo::define Point { - property x -get {} -set - } -} -returnCodes error -cleanup { - parent destroy -} -result {missing body to go with -set option} -test oo-46.12 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {} -get {return ok} - } - [Point new] configure -x -} -cleanup { - parent destroy -} -result ok -test oo-46.13 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -kind gorp - } -} -returnCodes error -cleanup { - parent destroy -} -result {bad kind "gorp": must be readable, readwrite, or writable} -test oo-46.14 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -k reada -g {return ok} - } - [Point new] configure -x -} -cleanup { - parent destroy -} -result ok -test oo-46.15 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property {*}{ - x -kind writable - y -get {return ok} - } - } - [Point new] configure -y -} -cleanup { - parent destroy -} -result ok -test oo-46.16 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent - unset -nocomplain msg -} -body { - oo::configurable create Point { - superclass parent - variable xy - property x -kind readable -get {return $xy} - property x -kind writable -set {set xy $value} - } - Point create pt - list [catch { - pt configure -x ok - } msg] $msg [catch { - pt configure -x - } msg] $msg [catch { - pt configure -y 1 - } msg] $msg -} -cleanup { - parent destroy -} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}} -test oo-46.17 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {return -code break} - } - while 1 { - [Point new] configure -x - break - } -} -returnCodes error -cleanup { - parent destroy -} -result {property getter for -x did a break} -test oo-46.18 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {return -code break} - } - while 1 { - [Point new] configure - break - } -} -returnCodes error -cleanup { - parent destroy -} -result {property getter for -x did a break} -test oo-46.19 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {error "boo"} - } - while 1 { - [Point new] configure -x - break - } -} -returnCodes error -cleanup { - parent destroy -} -result boo -test oo-46.20 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {error "boo"} - } - while 1 { - [Point new] configure - break - } -} -returnCodes error -cleanup { - parent destroy -} -result boo -test oo-46.21 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {return -code continue} - } - while 1 { - [Point new] configure -x - break - } -} -returnCodes error -cleanup { - parent destroy -} -result {property getter for -x did a continue} -test oo-46.22 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {return -level 2 ok} - } - apply {{} { - [Point new] configure - return bad - }} -} -cleanup { - parent destroy -} -result ok -test oo-46.23 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -get {return -level 2 ok} - } - apply {{} { - [Point new] configure -x - return bad - }} -} -cleanup { - parent destroy -} -result ok -test oo-46.24 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -set {return -code break} - } - while 1 { - [Point new] configure -x gorp - break - } -} -returnCodes error -cleanup { - parent destroy -} -result {property setter for -x did a break} -test oo-46.25 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -set {return -code continue} - } - while 1 { - [Point new] configure -x gorp - break - } -} -returnCodes error -cleanup { - parent destroy -} -result {property setter for -x did a continue} -test oo-46.26 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -set {error "boo"} - } - while 1 { - [Point new] configure -x gorp - break - } -} -returnCodes error -cleanup { - parent destroy -} -result boo -test oo-46.27 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - property x -set {return -level 2 ok} - } - apply {{} { - [Point new] configure -x gorp - return bad - }} -} -cleanup { - parent destroy -} -result ok -test oo-46.28 {TIP 558: properties: declaration semantics} -setup { - oo::class create parent -} -body { - oo::configurable create Point { - superclass parent - private property var - } - Point create pt - pt configure -var ok - pt configure -var -} -cleanup { - parent destroy -} -result ok - -test oo-47.1 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point {superclass parent} - list [catch {oo::define Point {property -x}} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {bad property name "-x": must not begin with - - while executing -"property -x" - (in definition script for class "::Point" line 1) - invoked from within -"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}} -test oo-47.2 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point {superclass parent} - list [catch {oo::define Point {property x -get}} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {missing body to go with -get option - while executing -"property x -get" - (in definition script for class "::Point" line 1) - invoked from within -"oo::define Point {property x -get}"} {TCL WRONGARGS}} -test oo-47.3 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point {superclass parent} - list [catch {oo::define Point {property x -set}} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {missing body to go with -set option - while executing -"property x -set" - (in definition script for class "::Point" line 1) - invoked from within -"oo::define Point {property x -set}"} {TCL WRONGARGS}} -test oo-47.4 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point {superclass parent} - list [catch {oo::define Point {property x -kind}} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {missing kind value to go with -kind option - while executing -"property x -kind" - (in definition script for class "::Point" line 1) - invoked from within -"oo::define Point {property x -kind}"} {TCL WRONGARGS}} -test oo-47.5 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point {superclass parent} - list [catch {oo::define Point {property x -kind gorp}} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {bad kind "gorp": must be readable, readwrite, or writable - while executing -"property x -kind gorp" - (in definition script for class "::Point" line 1) - invoked from within -"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}} -test oo-47.6 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point {superclass parent} - list [catch {oo::define Point {property x -gorp}} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {bad option "-gorp": must be -get, -kind, or -set - while executing -"property x -gorp" - (in definition script for class "::Point" line 1) - invoked from within -"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}} -test oo-47.7 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point { - superclass parent - property x - } - Point create pt - list [catch {pt configure -gorp} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {bad property "-gorp": must be -x - while executing -"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}} -test oo-47.8 {TIP 558: properties: error details} -setup { - oo::class create parent - unset -nocomplain msg opt -} -body { - oo::configurable create Point { - superclass parent - property x - } - Point create pt - list [catch {pt configure -gorp blarg} msg opt] \ - [dict get $opt -errorinfo] [dict get $opt -errorcode] -} -cleanup { - parent destroy -} -result {1 {bad property "-gorp": must be -x - while executing -"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}} cleanupTests return diff --git a/tests/ooProp.test b/tests/ooProp.test new file mode 100644 index 0000000..55f945a --- /dev/null +++ b/tests/ooProp.test @@ -0,0 +1,862 @@ +# This file contains a collection of tests for Tcl's built-in object system, +# specifically the parts that support configurable properties on objects. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2019-2020 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require TclOO 1.0.3 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { + namespace import -force ::tcltest::* +} + +test ooProp-1.1 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class properties c] [info class properties c -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test ooProp-1.2 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class properties c -all] [info class properties c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test ooProp-1.3 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class properties c] [info class properties c -writable] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class properties c] [info class properties c -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test ooProp-1.4 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class properties c -all] [info class properties c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class properties c -all] [info class properties c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test ooProp-1.5 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + oo::define d ::oo::configuresupport::readableproperties -set x y z + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + oo::define d ::oo::configuresupport::readableproperties -set r p q + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a h + oo::define d ::oo::configuresupport::readableproperties -set g h g + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define d ::oo::configuresupport::readableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}} +test ooProp-1.6 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + oo::define d ::oo::configuresupport::writableproperties -set x y z + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + oo::define d ::oo::configuresupport::writableproperties -set r p q + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a h + oo::define d ::oo::configuresupport::writableproperties -set g h g + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] + oo::define d ::oo::configuresupport::writableproperties -set + lappend result [info class properties d -all] [info class properties d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}} +test ooProp-1.7 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set + lappend result [info object properties o] [info object properties o -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}} +test ooProp-1.8 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h + lappend result [info object properties o] [info object properties o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set + lappend result [info object properties o] [info object properties o -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}} +test ooProp-1.9 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b + oo::define d ::oo::configuresupport::readableproperties -set c d + oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e + lappend result [info object properties o -all] [info object properties o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c d e f} {} {a b c d e f} {}} +test ooProp-1.10 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b + oo::define d ::oo::configuresupport::writableproperties -set c d + oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f + lappend result [info object properties o -all] [info object properties o -writable -all] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e + lappend result [info object properties o -all] [info object properties o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c d e f} {} {a b c d e f}} + +test ooProp-2.1 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + variable x y + method report {} { + lappend ::result "x=$x, y=$y" + } + } + set pt [Point new -x 3] + $pt report + $pt configure -y 4 + $pt report + lappend result [$pt configure -x],[$pt configure -y] [$pt configure] +} -cleanup { + parent destroy +} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}} +test ooProp-2.2 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + oo::configurable create 3DPoint { + superclass Point + property z + constructor args { + next -z 0 {*}$args + } + } + set pt [3DPoint new -x 3 -y 4 -z 5] + list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + [$pt configure] +} -cleanup { + parent destroy +} -result {3,4,5 {-x 3 -y 4 -z 5}} +test ooProp-2.3 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + set pt [Point new -x 3 -y 4] + oo::objdefine $pt property z + $pt configure -z 5 + list [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + [$pt configure] +} -cleanup { + parent destroy +} -result {3,4,5 {-x 3 -y 4 -z 5}} +test ooProp-2.4 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + [Point new] configure gorp +} -returnCodes error -cleanup { + parent destroy +} -result {bad property "gorp": must be -x or -y} +test ooProp-2.5 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + oo::configurable create 3DPoint { + superclass Point + property z + constructor args { + next -z 0 {*}$args + } + } + [3DPoint new] configure gorp +} -returnCodes error -cleanup { + parent destroy +} -result {bad property "gorp": must be -x, -y, or -z} +test ooProp-2.6 {TIP 558: properties: configurable class system} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + [Point create p] configure -x 1 -y +} -returnCodes error -cleanup { + parent destroy +} -result {wrong # args: should be "::p configure ?-option value ...?"} +test ooProp-2.7 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + property x y -kind writable + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + Point create p + list [p configure -y ok] [catch {p configure -y} msg] $msg +} -cleanup { + parent destroy +} -result {{} 1 {property "-y" is write only}} +test ooProp-2.8 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + property x y -kind readable + constructor args { + my configure -x 0 {*}$args + variable y 123 + } + } + Point create p + list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg +} -cleanup { + parent destroy +} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}} + +test ooProp-3.1 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property x -get { + global result + lappend result "get" + return [lrepeat 3 $xyz] + } -set { + global result + lappend result [list set $value] + set xyz [expr {$value * 3}] + } + } + Point create pt + pt configure -x 5 + lappend result >[pt configure -x]< +} -cleanup { + parent destroy +} -result {{set 5} get {>15 15 15<}} +test ooProp-3.2 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property x -get { + global result + lappend result "get" + return [lrepeat 3 $xyz] + } -set { + global result + lappend result [list set $value] + set xyz [expr {$value * 3}] + } y -kind readable -get {return $xyz} + } + Point create pt + pt configure -x 5 + lappend result >[pt configure -x]< [pt configure -y] +} -cleanup { + parent destroy +} -result {{set 5} get {>15 15 15<} 15} +test ooProp-3.3 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + variable xyz + property -x -get {return $xyz} + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "-x": must not begin with -} +test ooProp-3.4 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property "x y" + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x y": must be a simple word} +test ooProp-3.5 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property ::x + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "::x": must not contain namespace separators} +test ooProp-3.6 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x( + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x(": must not contain parentheses} +test ooProp-3.7 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x) + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad property name "x)": must not contain parentheses} +test ooProp-3.8 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -get + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -get option} +test ooProp-3.9 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -set + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -set option} +test ooProp-3.10 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -kind + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing kind value to go with -kind option} +test ooProp-3.11 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point {superclass parent} + oo::define Point { + property x -get {} -set + } +} -returnCodes error -cleanup { + parent destroy +} -result {missing body to go with -set option} +test ooProp-3.12 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {} -get {return ok} + } + [Point new] configure -x +} -cleanup { + parent destroy +} -result ok +test ooProp-3.13 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -kind gorp + } +} -returnCodes error -cleanup { + parent destroy +} -result {bad kind "gorp": must be readable, readwrite, or writable} +test ooProp-3.14 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -k reada -g {return ok} + } + [Point new] configure -x +} -cleanup { + parent destroy +} -result ok +test ooProp-3.15 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property {*}{ + x -kind writable + y -get {return ok} + } + } + [Point new] configure -y +} -cleanup { + parent destroy +} -result ok +test ooProp-3.16 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent + unset -nocomplain msg +} -body { + oo::configurable create Point { + superclass parent + variable xy + property x -kind readable -get {return $xy} + property x -kind writable -set {set xy $value} + } + Point create pt + list [catch { + pt configure -x ok + } msg] $msg [catch { + pt configure -x + } msg] $msg [catch { + pt configure -y 1 + } msg] $msg +} -cleanup { + parent destroy +} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}} +test ooProp-3.17 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code break} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a break} +test ooProp-3.18 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code break} + } + while 1 { + [Point new] configure + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a break} +test ooProp-3.19 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {error "boo"} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test ooProp-3.20 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {error "boo"} + } + while 1 { + [Point new] configure + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test ooProp-3.21 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -code continue} + } + while 1 { + [Point new] configure -x + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property getter for -x did a continue} +test ooProp-3.22 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -level 2 ok} + } + apply {{} { + [Point new] configure + return bad + }} +} -cleanup { + parent destroy +} -result ok +test ooProp-3.23 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -get {return -level 2 ok} + } + apply {{} { + [Point new] configure -x + return bad + }} +} -cleanup { + parent destroy +} -result ok +test ooProp-3.24 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -code break} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property setter for -x did a break} +test ooProp-3.25 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -code continue} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result {property setter for -x did a continue} +test ooProp-3.26 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {error "boo"} + } + while 1 { + [Point new] configure -x gorp + break + } +} -returnCodes error -cleanup { + parent destroy +} -result boo +test ooProp-3.27 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + property x -set {return -level 2 ok} + } + apply {{} { + [Point new] configure -x gorp + return bad + }} +} -cleanup { + parent destroy +} -result ok +test ooProp-3.28 {TIP 558: properties: declaration semantics} -setup { + oo::class create parent +} -body { + oo::configurable create Point { + superclass parent + private property var + } + Point create pt + pt configure -var ok + pt configure -var +} -cleanup { + parent destroy +} -result ok + +test ooProp-4.1 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property -x}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property name "-x": must not begin with - + while executing +"property -x" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}} +test ooProp-4.2 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -get}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing body to go with -get option + while executing +"property x -get" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -get}"} {TCL WRONGARGS}} +test ooProp-4.3 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -set}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing body to go with -set option + while executing +"property x -set" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -set}"} {TCL WRONGARGS}} +test ooProp-4.4 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -kind}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {missing kind value to go with -kind option + while executing +"property x -kind" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -kind}"} {TCL WRONGARGS}} +test ooProp-4.5 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -kind gorp}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad kind "gorp": must be readable, readwrite, or writable + while executing +"property x -kind gorp" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}} +test ooProp-4.6 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point {superclass parent} + list [catch {oo::define Point {property x -gorp}} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad option "-gorp": must be -get, -kind, or -set + while executing +"property x -gorp" + (in definition script for class "::Point" line 1) + invoked from within +"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}} +test ooProp-4.7 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point { + superclass parent + property x + } + Point create pt + list [catch {pt configure -gorp} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property "-gorp": must be -x + while executing +"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}} +test ooProp-4.8 {TIP 558: properties: error details} -setup { + oo::class create parent + unset -nocomplain msg opt +} -body { + oo::configurable create Point { + superclass parent + property x + } + Point create pt + list [catch {pt configure -gorp blarg} msg opt] \ + [dict get $opt -errorinfo] [dict get $opt -errorcode] +} -cleanup { + parent destroy +} -result {1 {bad property "-gorp": must be -x + while executing +"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From dafa1487f9a55f45fa67c4ff1583b3ac1397b940 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 7 Feb 2020 09:21:08 +0000 Subject: caching is one of the two hard things in CS (along with naming and off-by-one-errors) --- generic/tclOODefineCmds.c | 42 +++++++++++++++++++++++++++++++++++------- tests/ooProp.test | 23 +++++++++++++++++++++++ 2 files changed, 58 insertions(+), 7 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7b70c79..e68f15d 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -60,6 +60,7 @@ struct DeclaredSlot { */ static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); +static inline void BumpInstanceEpoch(Object *oPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr); static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, @@ -204,6 +205,33 @@ BumpGlobalEpoch( /* * ---------------------------------------------------------------------- * + * BumpInstanceEpoch -- + * + * Advances the epoch and clears the property cache of an object. The + * equivalent for classes is BumpGlobalEpoch(), as classes have a more + * complex set of relationships to other entities. + * + * ---------------------------------------------------------------------- + */ + +static inline void +BumpInstanceEpoch( + Object *oPtr) +{ + oPtr->epoch++; + if (oPtr->properties.allReadableCache) { + Tcl_DecrRefCount(oPtr->properties.allReadableCache); + oPtr->properties.allReadableCache = NULL; + } + if (oPtr->properties.allWritableCache) { + Tcl_DecrRefCount(oPtr->properties.allWritableCache); + oPtr->properties.allWritableCache = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * * RecomputeClassCacheFlag -- * * Determine whether the object is prototypical of its class, and hence @@ -280,7 +308,7 @@ TclOOObjectSetFilters( oPtr->filters.num = numFilters; oPtr->flags &= ~USE_CLASS_CACHE; } - oPtr->epoch++; /* Only this object can be affected. */ + BumpInstanceEpoch(oPtr); /* Only this object can be affected. */ } /* @@ -403,7 +431,7 @@ TclOOObjectSetMixins( } } } - oPtr->epoch++; + BumpInstanceEpoch(oPtr); } /* @@ -1494,7 +1522,7 @@ TclOODefineClassObjCmd( if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { - oPtr->epoch++; + BumpInstanceEpoch(oPtr); } } return TCL_OK; @@ -1704,7 +1732,7 @@ TclOODefineDeleteMethodObjCmd( } if (isInstanceDeleteMethod) { - oPtr->epoch++; + BumpInstanceEpoch(oPtr); } else { BumpGlobalEpoch(interp, oPtr->classPtr); } @@ -1864,7 +1892,7 @@ TclOODefineExportObjCmd( if (changed) { if (isInstanceExport) { - oPtr->epoch++; + BumpInstanceEpoch(oPtr); } else { BumpGlobalEpoch(interp, clsPtr); } @@ -2082,7 +2110,7 @@ TclOODefineRenameMethodObjCmd( } if (isInstanceRenameMethod) { - oPtr->epoch++; + BumpInstanceEpoch(oPtr); } else { BumpGlobalEpoch(interp, oPtr->classPtr); } @@ -2176,7 +2204,7 @@ TclOODefineUnexportObjCmd( if (changed) { if (isInstanceUnexport) { - oPtr->epoch++; + BumpInstanceEpoch(oPtr); } else { BumpGlobalEpoch(interp, clsPtr); } diff --git a/tests/ooProp.test b/tests/ooProp.test index 55f945a..256b934 100644 --- a/tests/ooProp.test +++ b/tests/ooProp.test @@ -208,6 +208,29 @@ test ooProp-1.10 {TIP 558: properties: core support} -setup { } -cleanup { parent destroy } -result {{} {} {} {a b c d e f} {} {a b c d e f}} +test ooProp-1.11 {TIP 558: properties: core support cache} -setup { + oo::class create parent + unset -nocomplain result +} -body { + oo::class create m { + superclass parent + ::oo::configuresupport::readableproperties -set a + ::oo::configuresupport::writableproperties -set c + } + oo::class create c { + superclass parent + ::oo::configuresupport::readableproperties -set b + ::oo::configuresupport::writableproperties -set d + } + c create o + lappend result [info object properties o -all -readable] \ + [info object properties o -all -writable] + oo::objdefine o mixin m + lappend result [info object properties o -all -readable] \ + [info object properties o -all -writable] +} -cleanup { + parent destroy +} -result {b d {a b} {c d}} test ooProp-2.1 {TIP 558: properties: configurable class system} -setup { oo::class create parent -- cgit v0.12 From 99145db40b9162cb8ac82c74d08da7f8f74eb911 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 15 Feb 2020 10:28:01 +0000 Subject: There are subtle cases where an append-if-new operation is really useful for a slot. --- doc/define.n | 6 ++++++ generic/tclOOScript.h | 43 ++++++++++++++++++++++++++----------------- tests/oo.test | 16 ++++++++-------- tools/tclOOScript.tcl | 45 +++++++++++++++++++++++++++------------------ 4 files changed, 67 insertions(+), 43 deletions(-) diff --git a/doc/define.n b/doc/define.n index 9046203..342b4c9 100644 --- a/doc/define.n +++ b/doc/define.n @@ -493,6 +493,12 @@ the slot: . This appends the given \fImember\fR elements to the slot definition. .TP +\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR? +.VS TIP558 +This appends the given \fImember\fR elements to the slot definition if they +do not already exist. +.VE TIP558 +.TP \fIslot\fR \fB\-clear\fR . This sets the slot definition to the empty list. diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 2b61866..b3ff92f 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -98,9 +98,9 @@ static const char *tclOOSetupScript = "\t\t\tif {![info object isa class $d]} {\n" "\t\t\t\tcontinue\n" "\t\t\t}\n" -"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" +"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n" "\t\t}\n" -"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" +"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n" "\t}\n" "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" "\t\tset originDelegate [DelegateName $originObject]\n" @@ -141,34 +141,44 @@ static const char *tclOOSetupScript = "\t\t::namespace delete tmp\n" "\t}\n" "\tdefine Slot {\n" -"\t\tmethod Get {} {\n" +"\t\tmethod Get -unexport {} {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" -"\t\tmethod Set list {\n" +"\t\tmethod Set -unexport list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" -"\t\tmethod Resolve list {\n" +"\t\tmethod Resolve -unexport list {\n" "\t\t\treturn $list\n" "\t\t}\n" -"\t\tmethod -set args {\n" +"\t\tmethod -set -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\ttailcall my Set $args\n" "\t\t}\n" -"\t\tmethod -append args {\n" +"\t\tmethod -append -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$current {*}$args]\n" "\t\t}\n" -"\t\tmethod -clear {} {tailcall my Set {}}\n" -"\t\tmethod -prepend args {\n" +"\t\tmethod -appendifnew -export args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\tset args [lmap a $args {\n" +"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n" +"\t\t\t\tif {$a in $current} continue\n" +"\t\t\t\tset a\n" +"\t\t\t}]\n" +"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" +"\t\t}\n" +"\t\tmethod -clear -export {} {tailcall my Set {}}\n" +"\t\tmethod -prepend -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$args {*}$current]\n" "\t\t}\n" -"\t\tmethod -remove args {\n" +"\t\tmethod -remove -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" @@ -177,7 +187,7 @@ static const char *tclOOSetupScript = "\t\t\t}]\n" "\t\t}\n" "\t\tforward --default-operation my -append\n" -"\t\tmethod unknown {args} {\n" +"\t\tmethod unknown -unexport {args} {\n" "\t\t\tset def --default-operation\n" "\t\t\tif {[llength $args] == 0} {\n" "\t\t\t\ttailcall my $def\n" @@ -186,13 +196,12 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t\tnext {*}$args\n" "\t\t}\n" -"\t\texport -set -append -clear -prepend -remove\n" -"\t\tunexport unknown destroy\n" +"\t\tunexport destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" "\tobjdefine define::mixin forward --default-operation my -set\n" "\tobjdefine objdefine::mixin forward --default-operation my -set\n" -"\tdefine object method {originObject} {\n" +"\tdefine object method -unexport {originObject} {\n" "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" "\t\t\tset args [info args $p]\n" "\t\t\tset idx -1\n" @@ -219,7 +228,7 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t}\n" "\t}\n" -"\tdefine class method {originObject} {\n" +"\tdefine class method -unexport {originObject} {\n" "\t\tnext $originObject\n" "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "\t}\n" @@ -235,7 +244,7 @@ static const char *tclOOSetupScript = "\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" "\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" "\t\t\t\t\t}\n" -"\t\t\t\t\tmethod {originObject} {\n" +"\t\t\t\t\tmethod -unexport {originObject} {\n" "\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" "\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t\t}\n" @@ -439,7 +448,7 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\t::oo::class create configurable {\n" "\t\t\tprivate variable my\n" -"\t\t\tmethod configure args {\n" +"\t\t\tmethod configure -export args {\n" "\t\t\t\t::if {![::info exists my]} {\n" "\t\t\t\t\t::set my [::namespace which my]\n" "\t\t\t\t}\n" diff --git a/tests/oo.test b/tests/oo.test index c1907d5..0fa2559 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4163,7 +4163,7 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ - {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops} + {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] @@ -4193,25 +4193,25 @@ proc getMethods obj { } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -prepend -remove -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -prepend -remove -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -prepend -remove -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -prepend -remove -set} {Get Set}} +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.10 {TIP 516: slots - resolution} -setup { oo::class create parent set result {} diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index e918787..7355ad0 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -153,9 +153,9 @@ if {![info object isa class $d]} { continue } - define $delegate ::oo::define::superclass -append $d + define $delegate ::oo::define::superclass -appendifnew $d } - objdefine $class ::oo::objdefine::mixin -append $delegate + objdefine $class ::oo::objdefine::mixin -appendifnew $delegate } # ---------------------------------------------------------------------- @@ -257,7 +257,7 @@ # # ------------------------------------------------------------------ - method Get {} { + method Get -unexport {} { return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" } @@ -270,7 +270,7 @@ # # ------------------------------------------------------------------ - method Set list { + method Set -unexport list { return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" } @@ -284,7 +284,7 @@ # # ------------------------------------------------------------------ - method Resolve list { + method Resolve -unexport list { return $list } @@ -297,25 +297,35 @@ # # ------------------------------------------------------------------ - method -set args { + method -set -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] tailcall my Set $args } - method -append args { + method -append -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } - method -clear {} {tailcall my Set {}} - method -prepend args { + method -appendifnew -export args { + set my [namespace which my] + set current [uplevel 1 [list $my Get]] + set args [lmap a $args { + set a [uplevel 1 [list $my Resolve $a]] + if {$a in $current} continue + set a + }] + tailcall my Set [list {*}$current {*}$args] + } + method -clear -export {} {tailcall my Set {}} + method -prepend -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$args {*}$current] } - method -remove args { + method -remove -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] @@ -326,7 +336,7 @@ # Default handling forward --default-operation my -append - method unknown {args} { + method unknown -unexport {args} { set def --default-operation if {[llength $args] == 0} { tailcall my $def @@ -336,9 +346,8 @@ next {*}$args } - # Set up what is exported and what isn't - export -set -append -clear -prepend -remove - unexport unknown destroy + # Hide destroy + unexport destroy } # Set the default operation differently for these slots @@ -356,7 +365,7 @@ # # ---------------------------------------------------------------------- - define object method {originObject} { + define object method -unexport {originObject} { # Copy over the procedures from the original namespace foreach p [info procs [info object namespace $originObject]::*] { set args [info args $p] @@ -397,7 +406,7 @@ # # ---------------------------------------------------------------------- - define class method {originObject} { + define class method -unexport {originObject} { next $originObject # Rebuild the class inheritance delegation class ::oo::UpdateClassDelegatesAfterClone $originObject [self] @@ -424,7 +433,7 @@ ::return -code error -errorcode {TCLOO SINGLETON} \ "may not destroy a singleton object" } - method {originObject} { + method -unexport {originObject} { ::return -code error -errorcode {TCLOO SINGLETON} \ "may not clone a singleton object" } @@ -730,7 +739,7 @@ # Method for providing client access to the property mechanism. # Has a user-facing API similar to that of [chan configure]. # - method configure args { + method configure -export args { ::if {![::info exists my]} { ::set my [::namespace which my] } -- cgit v0.12 From 004c1e1c8e680a5b55b04bc747c5e8575538dd56 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 22 Feb 2020 12:31:11 +0000 Subject: Less contorted code --- tools/tclOOScript.tcl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 7355ad0..8167f83 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -311,12 +311,13 @@ method -appendifnew -export args { set my [namespace which my] set current [uplevel 1 [list $my Get]] - set args [lmap a $args { + foreach a $args { set a [uplevel 1 [list $my Resolve $a]] - if {$a in $current} continue - set a - }] - tailcall my Set [list {*}$current {*}$args] + if {$a ni $current} { + lappend current $a + } + } + tailcall my Set $current } method -clear -export {} {tailcall my Set {}} method -prepend -export args { -- cgit v0.12 From cc185b1d763af5b2a80b5fc5c25fb2f0c69d0661 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Sep 2022 11:50:31 +0000 Subject: eliminate some compiler warnings --- generic/tclOODefineCmds.c | 28 ++++++++++++++-------------- generic/tclOOInfo.c | 4 ++-- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index d360516..bac7c15 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -3131,10 +3131,10 @@ InstallReadableProps( if (objc == 0) { ckfree(props->readable.list); } else if (i) { - props->readable.list = ckrealloc(props->readable.list, + props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, sizeof(Tcl_Obj *) * objc); } else { - props->readable.list = ckalloc(sizeof(Tcl_Obj *) * objc); + props->readable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); } } props->readable.num = 0; @@ -3155,7 +3155,7 @@ InstallReadableProps( */ if (n != objc) { - props->readable.list = ckrealloc(props->readable.list, + props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); @@ -3164,7 +3164,7 @@ InstallReadableProps( static int ClassRPropsGet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3198,7 +3198,7 @@ ClassRPropsGet( static int ClassRPropsSet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3234,7 +3234,7 @@ ClassRPropsSet( static int ObjRPropsGet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3263,7 +3263,7 @@ ObjRPropsGet( static int ObjRPropsSet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3327,10 +3327,10 @@ InstallWritableProps( if (objc == 0) { ckfree(props->writable.list); } else if (i) { - props->writable.list = ckrealloc(props->writable.list, + props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, sizeof(Tcl_Obj *) * objc); } else { - props->writable.list = ckalloc(sizeof(Tcl_Obj *) * objc); + props->writable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); } } props->writable.num = 0; @@ -3351,7 +3351,7 @@ InstallWritableProps( */ if (n != objc) { - props->writable.list = ckrealloc(props->writable.list, + props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); @@ -3360,7 +3360,7 @@ InstallWritableProps( static int ClassWPropsGet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3394,7 +3394,7 @@ ClassWPropsGet( static int ClassWPropsSet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3430,7 +3430,7 @@ ClassWPropsSet( static int ObjWPropsGet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3459,7 +3459,7 @@ ObjWPropsGet( static int ObjWPropsSet( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 81647b0..f7f5de1 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -1739,7 +1739,7 @@ static const char *const propOptNames[] = { static int InfoClassPropCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1802,7 +1802,7 @@ InfoClassPropCmd( static int InfoObjectPropCmd( - ClientData clientData, + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -- cgit v0.12 From 10c71dc8b9b6b31ccb669be71f22adafdddfce6e Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 May 2023 13:31:30 +0000 Subject: Use modern copyright symbol, in line with rest of code --- doc/configurable.n | 2 +- tests/ooProp.test | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/configurable.n b/doc/configurable.n index 9a2a478..dd1e09e 100644 --- a/doc/configurable.n +++ b/doc/configurable.n @@ -1,5 +1,5 @@ '\" -'\" Copyright (c) 2019 Donal K. Fellows +'\" Copyright © 2019 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/ooProp.test b/tests/ooProp.test index fd77997..8120f88 100644 --- a/tests/ooProp.test +++ b/tests/ooProp.test @@ -3,7 +3,7 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2019-2020 Donal K. Fellows +# Copyright © 2019-2020 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -- cgit v0.12 From 75554201664b7e701f13d53c97aa385cd1ff0114 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 May 2023 14:07:59 +0000 Subject: Add doc comments, fix a typo in a manpage --- doc/configurable.n | 2 +- generic/tclOOCall.c | 82 +++++++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 71 insertions(+), 13 deletions(-) diff --git a/doc/configurable.n b/doc/configurable.n index dd1e09e..6477894 100644 --- a/doc/configurable.n +++ b/doc/configurable.n @@ -62,7 +62,7 @@ If passed no additional arguments, the \fBconfigure\fR method returns an alphabetically sorted dictionary of all \fIreadable\fR and \fIread-write\fR properties and their current values. .PP -If passed a single addiional argument, that argument to the \fBconfigure\fR +If passed a single additional argument, that argument to the \fBconfigure\fR method must be the name of a property to read (or an unambiguous prefix thereof); its value is returned. .PP diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 5a0eeea..57f8860 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -2110,11 +2110,24 @@ AddDefinitionNamespaceToChain( definePtr->num++; } +/* + * ---------------------------------------------------------------------- + * + * FindClassProps -- + * + * Discover the properties known to a class and its superclasses. + * The property names become the keys in the accumulator hash table + * (which is used as a set). + * + * ---------------------------------------------------------------------- + */ + static void FindClassProps( - Class *clsPtr, - int writable, - Tcl_HashTable *accumulator) + Class *clsPtr, /* The object to inspect. Must exist. */ + int writable, /* Whether we're after the readable or writable + * property set. */ + Tcl_HashTable *accumulator) /* Where to gather the names. */ { int i, dummy; Tcl_Obj *propName; @@ -2148,11 +2161,24 @@ FindClassProps( } } +/* + * ---------------------------------------------------------------------- + * + * FindObjectProps -- + * + * Discover the properties known to an object and all its classes. + * The property names become the keys in the accumulator hash table + * (which is used as a set). + * + * ---------------------------------------------------------------------- + */ + static void FindObjectProps( - Object *oPtr, - int writable, - Tcl_HashTable *accumulator) + Object *oPtr, /* The object to inspect. Must exist. */ + int writable, /* Whether we're after the readable or writable + * property set. */ + Tcl_HashTable *accumulator) /* Where to gather the names. */ { int i, dummy; Tcl_Obj *propName; @@ -2173,11 +2199,27 @@ FindObjectProps( FindClassProps(oPtr->selfCls, writable, accumulator); } +/* + * ---------------------------------------------------------------------- + * + * TclOOGetAllClassProperties -- + * + * Get the list of all properties known to a class, including to its + * superclasses. Manages a cache so this operation is usually cheap. + * The order of properties in the resulting list is undefined. + * + * ---------------------------------------------------------------------- + */ + Tcl_Obj * TclOOGetAllClassProperties( - Class *clsPtr, - int writable, - int *allocated) + Class *clsPtr, /* The class to inspect. Must exist. */ + int writable, /* Whether to get writable properties. If + * false, readable properties will be returned + * instead. */ + int *allocated) /* Address of variable to set to true if a + * Tcl_Obj was allocated and may be safely + * modified by the caller. */ { Tcl_HashTable hashTable; FOREACH_HASH_DECLS; @@ -2239,11 +2281,27 @@ TclOOGetAllClassProperties( return result; } +/* + * ---------------------------------------------------------------------- + * + * TclOOGetAllObjectProperties -- + * + * Get the list of all properties known to a object, including to its + * classes. Manages a cache so this operation is usually cheap. + * The order of properties in the resulting list is undefined. + * + * ---------------------------------------------------------------------- + */ + Tcl_Obj * TclOOGetAllObjectProperties( - Object *oPtr, - int writable, - int *allocated) + Object *oPtr, /* The object to inspect. Must exist. */ + int writable, /* Whether to get writable properties. If + * false, readable properties will be returned + * instead. */ + int *allocated) /* Address of variable to set to true if a + * Tcl_Obj was allocated and may be safely + * modified by the caller. */ { Tcl_HashTable hashTable; FOREACH_HASH_DECLS; -- cgit v0.12 From fea912c676a71b362b8c7d77e3f4242e374de1bb Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 1 May 2023 15:08:08 +0000 Subject: Remove IDE guff --- .project | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/.project b/.project index 43e03b1..eddd834 100644 --- a/.project +++ b/.project @@ -5,23 +5,7 @@ - - org.eclipse.cdt.managedbuilder.core.genmakebuilder - clean,full,incremental, - - - - - org.eclipse.cdt.managedbuilder.core.ScannerConfigBuilder - full,incremental, - - - - org.eclipse.cdt.core.cnature - org.eclipse.cdt.core.ccnature - org.eclipse.cdt.managedbuilder.core.managedBuildNature - org.eclipse.cdt.managedbuilder.core.ScannerConfigNature -- cgit v0.12