From 08c1b1b2c6895f2120d1ba2bfec96e1af38b13ae Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Aug 2025 14:19:13 +0000 Subject: Complete the moving of the definition of slots entirely into C --- generic/tclOO.c | 69 +++++++++---------- generic/tclOODefineCmds.c | 164 +++++++++++++++++++++++++++++++--------------- generic/tclOOScript.h | 7 +- tools/tclOOScript.tcl | 27 -------- 4 files changed, 144 insertions(+), 123 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0da8b7f..0e6ff6f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -51,31 +51,31 @@ static const struct DefineCommands { Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { - {"classmethod", TclOODefineClassMethodObjCmd, 0}, - {"constructor", TclOODefineConstructorObjCmd, 0}, + {"classmethod", TclOODefineClassMethodObjCmd, 0}, + {"constructor", TclOODefineConstructorObjCmd, 0}, {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, - {"destructor", TclOODefineDestructorObjCmd, 0}, - {"export", TclOODefineExportObjCmd, 0}, - {"forward", TclOODefineForwardObjCmd, 0}, - {"initialise", TclOODefineInitialiseObjCmd, 0}, - {"initialize", TclOODefineInitialiseObjCmd, 0}, - {"method", TclOODefineMethodObjCmd, 0}, - {"private", TclOODefinePrivateObjCmd, 0}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, - {"self", TclOODefineSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 0}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, + {"destructor", TclOODefineDestructorObjCmd, 0}, + {"export", TclOODefineExportObjCmd, 0}, + {"forward", TclOODefineForwardObjCmd, 0}, + {"initialise", TclOODefineInitialiseObjCmd, 0}, + {"initialize", TclOODefineInitialiseObjCmd, 0}, + {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, + {"self", TclOODefineSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, {NULL, NULL, 0} }, objdefCmds[] = { - {"class", TclOODefineClassObjCmd, 1}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, - {"export", TclOODefineExportObjCmd, 1}, - {"forward", TclOODefineForwardObjCmd, 1}, - {"method", TclOODefineMethodObjCmd, 1}, - {"private", TclOODefinePrivateObjCmd, 1}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, - {"self", TclOODefineObjSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 1}, + {"class", TclOODefineClassObjCmd, 1}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, + {"export", TclOODefineExportObjCmd, 1}, + {"forward", TclOODefineForwardObjCmd, 1}, + {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; @@ -96,7 +96,7 @@ static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method **newMPtrPtr); static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); -static void DeletedHelpersNamespace(void *clientData); +static Tcl_NamespaceDeleteProc DeletedHelpersNamespace; static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; @@ -105,23 +105,17 @@ static void InitClassSystemRoots(Tcl_Interp *interp, Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static Tcl_InterpDeleteProc KillFoundation; -static void MyDeleted(void *clientData); -static void ObjectNamespaceDeleted(void *clientData); +static Tcl_CmdDeleteProc MyDeleted; +static Tcl_NamespaceDeleteProc ObjectNamespaceDeleted; static Tcl_CommandTraceProc ObjectRenamedTrace; static inline void RemoveClass(Class **list, size_t num, size_t idx); static inline void RemoveObject(Object **list, size_t num, size_t idx); static inline void SquelchCachedName(Object *oPtr); -static int PublicNRObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static int PrivateNRObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static int MyClassNRObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static void MyClassDeleted(void *clientData); +static Tcl_ObjCmdProc PublicNRObjectCmd; +static Tcl_ObjCmdProc PrivateNRObjectCmd; +static Tcl_ObjCmdProc MyClassNRObjCmd; +static Tcl_CmdDeleteProc MyClassDeleted; /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -172,8 +166,9 @@ static const char initScript[] = "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" #endif "package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};" -"namespace eval ::oo { variable version " TCLOO_VERSION " };" -"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +"namespace eval ::oo {" +" variable version " TCLOO_VERSION " patchlevel " TCLOO_PATCHLEVEL +"};"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ /* " tcloo.tcl OO_LIBRARY oo::library;"; */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 8d99b07..be33f40 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,16 +37,17 @@ typedef struct DeclaredSlot { const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; + const char *defaultOp; // The default op, if not set by the class } DeclaredSlot; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter,resolver,defOp) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \ setter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \ - resolver, NULL, NULL}} + resolver, NULL, NULL}, (defOp)} typedef struct DeclaredSlotMethod { const char *name; @@ -190,26 +191,26 @@ static int ResolveClass(void *clientData, */ static const DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL), - SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass), - SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass), - SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL), - SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL), - SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass), - SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL), + SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL, NULL), + SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass, "-set"), + SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass, "-set"), + SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL, NULL), + SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL, NULL), + SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass, "-set"), + SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL, NULL), SLOT("configuresupport::readableproperties", Configurable_ClassReadableProps_Get, - Configurable_ClassReadableProps_Set, NULL), + Configurable_ClassReadableProps_Set, NULL, NULL), SLOT("configuresupport::writableproperties", Configurable_ClassWritableProps_Get, - Configurable_ClassWritableProps_Set, NULL), + Configurable_ClassWritableProps_Set, NULL, NULL), SLOT("configuresupport::objreadableproperties", Configurable_ObjectReadableProps_Get, - Configurable_ObjectReadableProps_Set, NULL), + Configurable_ObjectReadableProps_Set, NULL, NULL), SLOT("configuresupport::objwritableproperties", Configurable_ObjectWritableProps_Get, - Configurable_ObjectWritableProps_Set, NULL), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + Configurable_ObjectWritableProps_Set, NULL, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, 0} }; static const DeclaredSlotMethod slotMethods[] = { @@ -2355,6 +2356,75 @@ TclOODefineRenameMethodObjCmd( } /* + * Unexporting is done by removing the PUBLIC_METHOD flag from the method + * record. If there is no such method in this object or class (i.e. the method + * comes from something inherited from or that we're an instance of) then we + * put in a blank record without that flag; such records are skipped over by + * the call chain engine *except* for their flags member. + * + * Caller has the responsibility to update any epochs if necessary. + */ + +static int +UnexportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr, + &isNew); + Method *mPtr; + if (isNew) { + mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + } else { + mPtr = (Method *) Tcl_GetHashValue(hPtr); + } + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +static int +UnexportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) + Tcl_Alloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } + + int isNew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr, + &isNew); + Method *mPtr; + if (isNew) { + mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + } else { + mPtr = (Method *) Tcl_GetHashValue(hPtr); + } + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +/* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- @@ -2374,10 +2444,8 @@ TclOODefineUnexportObjCmd( { int isInstanceUnexport = (clientData != NULL); Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); @@ -2397,42 +2465,10 @@ TclOODefineUnexportObjCmd( } for (i = 1; i < objc; i++) { - /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the - * method record. If there is no such method in this object or class - * (i.e. the method comes from something inherited from or that we're - * an instance of) then we put in a blank record without that flag; - * such records are skipped over by the call chain engine *except* for - * their flags member. - */ - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + changed |= UnexportInstanceMethod(oPtr, objv[i]); } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - changed = 1; + changed |= UnexportMethod(clsPtr, objv[i]); } } @@ -2510,8 +2546,9 @@ Tcl_ClassSetDestructor( * * TclOODefineSlots -- * - * Create the "::oo::Slot" class and its standard instances. Class - * definition is empty at the stage (added by scripting). + * Create the "::oo::Slot" class and its standard instances. These are + * basically lists at the low level of TclOO; this provides a more + * consistent interface to them. * * ---------------------------------------------------------------------- */ @@ -2542,6 +2579,19 @@ TclOODefineSlots( Tcl_BounceRefCount(name); } + // If a slot can't figure out what method to call directly, it uses + // --default-operation. That defaults to -append; we set that here. + Tcl_Obj *defaults[] = { + fPtr->myName, + Tcl_NewStringObj("-append", TCL_AUTO_LENGTH) + }; + TclOONewForwardMethod(interp, (Class *) slotCls, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, defaults)); + + // Hide the destroy method. (We're definitely taking a ref to the name.) + UnexportMethod((Class *) slotCls, + Tcl_NewStringObj("destroy", TCL_AUTO_LENGTH)); + for (slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); @@ -2557,6 +2607,14 @@ TclOODefineSlots( TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0, &slotPtr->resolverType, NULL); } + if (slotPtr->defaultOp) { + Tcl_Obj *slotDefaults[] = { + fPtr->myName, + Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH) + }; + TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults)); + } } return TCL_OK; } diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 318a7ac..4c5f1a2 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,11 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tdefine Slot forward --default-operation my -append\n" -"\tdefine Slot unexport destroy\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 -unexport {originObject} {\n" "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" "\t\t\tset args [info args $p]\n" @@ -115,7 +110,7 @@ static const char *tclOOSetupScript = "\tclass create configurable\n" "\tdefine configurable superclass -set class\n" "\tdefine configurable constructor {{definitionScript \"\"}} {\n" -"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n" +"\t\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n" "\t\tnext $definitionScript\n" "\t}\n" "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 66e125d..6b17483 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -14,33 +14,6 @@ ::namespace eval ::oo { # ---------------------------------------------------------------------- # - # Slot -- - # - # The class of slot operations, which are basically lists at the low - # level of TclOO; this provides a more consistent interface to them. - # - # ---------------------------------------------------------------------- - - # ------------------------------------------------------------------ - # - # Slot --default-operation -- - # - # If a slot can't figure out what method to call directly, it - # uses --default-operation. - # - # ------------------------------------------------------------------ - define Slot forward --default-operation my -append - - # Hide destroy - define Slot unexport destroy - - # Set the default operation differently for these slots - objdefine define::superclass forward --default-operation my -set - objdefine define::mixin forward --default-operation my -set - objdefine objdefine::mixin forward --default-operation my -set - - # ---------------------------------------------------------------------- - # # oo::object -- # # Handler for cloning objects that clones basic bits (only!) of the -- cgit v0.12 From feb0337f75767c1e1dbf9145ebe9bdc6810c13b4 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Aug 2025 14:20:33 +0000 Subject: Tinkering, making code simpler or easier to maintain --- generic/tclOODefineCmds.c | 220 +++++++++++++++++++++++++--------------------- generic/tclOOScript.h | 22 ++--- tools/tclOOScript.tcl | 32 ++++--- win/Makefile.in | 2 +- 4 files changed, 151 insertions(+), 125 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index be33f40..3fe4799 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1231,6 +1231,119 @@ MagicDefinitionInvoke( /* * ---------------------------------------------------------------------- * + * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod -- + * + * Exporting and unexporting are done by setting or removing the + * PUBLIC_METHOD flag on the method record. If there is no such method in + * this class or object (i.e. the method comes from something inherited + * from or that we're an instance of) then we put in a blank record just + * to hold that flag (or its absence); such records are skipped over by + * the call chain engine *except* for their flags member. + * + * Caller has the responsibility to update any epochs if necessary. + * + * ---------------------------------------------------------------------- + */ + +// Make a blank method record or look up the existing one. +static inline Method * +GetOrCreateMethod( + Tcl_HashTable *tablePtr, + Tcl_Obj *namePtr, + int *isNew) +{ + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr, + isNew); + if (*isNew) { + Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + return mPtr; + } else { + return (Method *) Tcl_GetHashValue(hPtr); + } +} + +static int +ExportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +// Make the table of methods in the instance if it doesn't already exist. +static inline void +InitMethodTable( + Object *oPtr) +{ + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } +} + +static int +ExportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * * Implementation of the "oo::define" command. Works by effectively doing @@ -1939,22 +2052,18 @@ TclOODefineExportObjCmd( Tcl_Obj *const *objv) { int isInstanceExport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } - clsPtr = oPtr->classPtr; + Class *clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", TCL_AUTO_LENGTH)); @@ -1973,33 +2082,9 @@ TclOODefineExportObjCmd( */ if (isInstanceExport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); - } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); + changed |= ExportInstanceMethod(oPtr, objv[i]); } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { - mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; - changed = 1; + changed |= ExportMethod(clsPtr, objv[i]); } } @@ -2356,75 +2441,6 @@ TclOODefineRenameMethodObjCmd( } /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the method - * record. If there is no such method in this object or class (i.e. the method - * comes from something inherited from or that we're an instance of) then we - * put in a blank record without that flag; such records are skipped over by - * the call chain engine *except* for their flags member. - * - * Caller has the responsibility to update any epochs if necessary. - */ - -static int -UnexportMethod( - Class *clsPtr, - Tcl_Obj *namePtr) -{ - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, namePtr, - &isNew); - Method *mPtr; - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = namePtr; - Tcl_IncrRefCount(namePtr); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - isNew = 1; - } - return isNew; -} - -static int -UnexportInstanceMethod( - Object *oPtr, - Tcl_Obj *namePtr) -{ - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - - int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, namePtr, - &isNew); - Method *mPtr; - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = namePtr; - Tcl_IncrRefCount(namePtr); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - isNew = 1; - } - return isNew; -} - -/* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 4c5f1a2..390b034 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -72,24 +72,24 @@ static const char *tclOOSetupScript = "\t}\n" "\tclass create singleton\n" "\tdefine singleton superclass -set class\n" -"\tdefine singleton variable -set object\n" "\tdefine singleton unexport create createWithNamespace\n" "\tdefine singleton method new args {\n" +"\t\tvariable object\n" "\t\tif {![info exists object] || ![info object isa object $object]} {\n" "\t\t\tset object [next {*}$args]\n" -"\t\t\t::oo::objdefine $object {\n" -"\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t\tmethod -unexport {originObject} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t}\n" +"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n" "\t\t}\n" "\t\treturn $object\n" "\t}\n" +"\tclass create SingletonInstance\n" +"\tdefine SingletonInstance method destroy {} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not destroy a singleton object\"\n" +"\t}\n" +"\tdefine SingletonInstance method -unexport {originObject} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not clone a singleton object\"\n" +"\t}\n" "\tclass create abstract\n" "\tdefine abstract superclass -set class\n" "\tdefine abstract unexport create createWithNamespace new\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 6b17483..b17d7d0 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -92,27 +92,37 @@ class create singleton define singleton superclass -set class - define singleton variable -set object define singleton unexport create createWithNamespace define singleton method new args { + variable object if {![info exists object] || ![info object isa object $object]} { set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - method -unexport {originObject} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" - } - } + ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance } return $object } # ---------------------------------------------------------------------- # + # oo::SingletonInstance -- + # + # A mixin used to make an object so it won't be destroyed or cloned (or + # at least not easily). + # + # ---------------------------------------------------------------------- + + class create SingletonInstance + define SingletonInstance method destroy {} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not destroy a singleton object" + } + define SingletonInstance method -unexport {originObject} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not clone a singleton object" + } + + # ---------------------------------------------------------------------- + # # oo::abstract -- # # A metaclass that is used to make classes that can't be directly diff --git a/win/Makefile.in b/win/Makefile.in index e039f64..bcb35c1 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -767,7 +767,7 @@ tclWinPanic.${OBJEXT}: tclWinPanic.c .rc.$(RES): $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ - +tclOO.${OBJEXT}: tclOO.c tclOOScript.h #-------------------------------------------------------------------------- # Minizip implementation -- cgit v0.12 From 2439cb752aa32192e337a9be349aae04bce3cd2f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Aug 2025 14:23:48 +0000 Subject: Move more machinery into C from the TclOO init script --- generic/tclOO.c | 179 ++++++++++++++++++++++++++++++---- generic/tclOOBasic.c | 216 +++++++++++++++++++++++++++++++++++++++++ generic/tclOODefineCmds.c | 93 +++++++++++++++--- generic/tclOOInt.h | 11 ++- generic/tclOOScript.h | 104 ++++---------------- tests/oo.test | 31 +++++- tools/tclOOScript.tcl | 240 +++++++--------------------------------------- 7 files changed, 547 insertions(+), 327 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0e6ff6f..4ebcf77 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -105,6 +105,9 @@ static void InitClassSystemRoots(Tcl_Interp *interp, Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static Tcl_InterpDeleteProc KillFoundation; +static void MakeAdditionalClasses(Foundation *fPtr, + Tcl_Namespace *defineNs, + Tcl_Namespace *objDefineNs); static Tcl_CmdDeleteProc MyDeleted; static Tcl_NamespaceDeleteProc ObjectNamespaceDeleted; static Tcl_CommandTraceProc ObjectRenamedTrace; @@ -137,6 +140,7 @@ static const DeclaredClassMethod objMethods[] = { DCM("varname", 0, TclOO_Object_VarName), {NULL, 0, {0, NULL, NULL, NULL, NULL}} }, clsMethods[] = { + DCM("", 0, TclOO_Class_Cloned), DCM("create", 1, TclOO_Class_Create), DCM("new", 1, TclOO_Class_New), DCM("createWithNamespace", 0, TclOO_Class_CreateNs), @@ -144,6 +148,13 @@ static const DeclaredClassMethod objMethods[] = { }, cfgMethods[] = { DCM("configure", 1, TclOO_Configurable_Configure), {NULL, 0, {0, NULL, NULL, NULL, NULL}} +}, singletonMethods[] = { + DCM("new", 1, TclOO_Singleton_New), + {NULL, 0, {0, NULL, NULL, NULL, NULL}} +}, singletonInstanceMethods[] = { + DCM("", 0, TclOO_SingletonInstance_Cloned), + DCM("destroy", 1, TclOO_SingletonInstance_Destroy), + {NULL, 0, {0, NULL, NULL, NULL, NULL}} }; /* @@ -157,6 +168,16 @@ static const Tcl_MethodType classConstructor = { }; /* + * And the oo::configurable constructor... + */ + +static const Tcl_MethodType configurableConstructor = { + TCL_OO_METHOD_VERSION_CURRENT, + "oo::configurable constructor", + TclOO_Configurable_Constructor, NULL, NULL +}; + +/* * Scripted parts of TclOO. First, the main script (cannot be outside this * file). */ @@ -479,25 +500,7 @@ InitFoundation( return TCL_ERROR; } - /* - * Make the configurable class and install its standard defined method. - */ - - Tcl_Object cfgCls = Tcl_NewObjectInstance(interp, - (Tcl_Class) fPtr->classCls, "::oo::configuresupport::configurable", - NULL, TCL_INDEX_NONE, NULL, 0); - TclOODefineBasicMethods(((Object *) cfgCls)->classPtr, cfgMethods); - - /* - * Don't have handles to these namespaces, so use Tcl_CreateObjCommand. - */ - - Tcl_CreateObjCommand(interp, - "::oo::configuresupport::configurableobject::property", - TclOODefinePropertyCmd, (void *) 1, NULL); - Tcl_CreateObjCommand(interp, - "::oo::configuresupport::configurableclass::property", - TclOODefinePropertyCmd, (void *) 0, NULL); + MakeAdditionalClasses(fPtr, define, objdef); /* * Evaluate the remaining definitions, which are a compiled-in Tcl script. @@ -505,7 +508,7 @@ InitFoundation( return Tcl_EvalEx(interp, tclOOSetupScript, TCL_INDEX_NONE, 0); } - + /* * ---------------------------------------------------------------------- * @@ -597,6 +600,142 @@ InitClassSystemRoots( */ } +static inline void +MarkAsMetaclass( + Foundation *fPtr, + Class *classPtr) +{ + Class **supers = (Class **) Tcl_Alloc(sizeof(Class *)); + supers[0] = fPtr->classCls; + AddRef(supers[0]->thisPtr); + TclOOSetSuperclasses(classPtr, 1, supers); +} +/* + * ---------------------------------------------------------------------- + * + * MakeAdditionalClasses -- + * Make the extra classes in TclOO that aren't core to how it functions. + * + * ---------------------------------------------------------------------- + */ +static void +MakeAdditionalClasses( + Foundation *fPtr, + Tcl_Namespace *defineNs, + Tcl_Namespace *objDefineNs) +{ + Tcl_Interp *interp = fPtr->interp; + + /* + * Make the singleton class, the SingletonInstance class, and install their + * standard defined methods. + */ + + // A metaclass that is used to make classes that only permit one instance + // of them to exist. See singleton(n). + Object *singletonObj = (Object *) Tcl_NewObjectInstance(interp, + (Tcl_Class) fPtr->classCls, "::oo::singleton", + NULL, TCL_INDEX_NONE, NULL, 0); + Class *singletonCls = singletonObj->classPtr; + TclOODefineBasicMethods(singletonCls, singletonMethods); + // Set the superclass to oo::class + MarkAsMetaclass(fPtr, singletonCls); + // Unexport methods + TclOOUnexportMethods(singletonCls, "create", "createWithNamespace", NULL); + + // A mixin used to make an object so it won't be destroyed or cloned (or + // at least not easily). + Object *singletonInst = (Object *) Tcl_NewObjectInstance(interp, + (Tcl_Class) fPtr->classCls, "::oo::SingletonInstance", + NULL, TCL_INDEX_NONE, NULL, 0); + TclOODefineBasicMethods(singletonInst->classPtr, singletonInstanceMethods); + + /* + * Make the abstract class. + */ + + // A metaclass that is used to make classes that can't be directly + // instantiated. See abstract(n). + Object *abstractCls = (Object *) Tcl_NewObjectInstance(interp, + (Tcl_Class) fPtr->classCls, "::oo::abstract", + NULL, TCL_INDEX_NONE, NULL, 0); + // Set the superclass to oo::class + MarkAsMetaclass(fPtr, abstractCls->classPtr); + // Unexport methods + TclOOUnexportMethods(abstractCls->classPtr, + "create", "createWithNamespace", "new", NULL); + + /* + * Make the configurable class and install its standard defined method. + */ + + // The class that contains the implementation of the actual + // 'configure' method (mixed into actually configurable classes). + // The 'configure' method is in tclOOBasic.c. + Object *cfgSupObj = (Object *) Tcl_NewObjectInstance(interp, + (Tcl_Class) fPtr->classCls, "::oo::configuresupport::configurable", + NULL, TCL_INDEX_NONE, NULL, 0); + Class *cfgSupCls = cfgSupObj->classPtr; + TclOODefineBasicMethods(cfgSupCls, cfgMethods); + + // Namespaces used as implementation vectors for oo::define and + // oo::objdefine when the class/instance is configurable. + // Note that these also contain commands implemented in C, + // especially the [property] definition command. + + Tcl_Namespace *cfgObjNs = Tcl_CreateNamespace(interp, + "::oo::configuresupport::configurableobject", NULL, NULL); + TclCreateObjCommandInNs(interp, "property", cfgObjNs, + TclOODefinePropertyCmd, INT2PTR(1) /*useInstance*/, NULL); + TclCreateObjCommandInNs(interp, "properties", cfgObjNs, + TclOODefinePropertyCmd, INT2PTR(1) /*useInstance*/, NULL); + Tcl_Export(interp, cfgObjNs, "property", /*reset*/1); + TclSetNsPath((Namespace *) cfgObjNs, 1, &objDefineNs); + + Tcl_Namespace *cfgClsNs = Tcl_CreateNamespace(interp, + "::oo::configuresupport::configurableclass", NULL, NULL); + TclCreateObjCommandInNs(interp, "property", cfgClsNs, + TclOODefinePropertyCmd, INT2PTR(0) /*useInstance*/, NULL); + TclCreateObjCommandInNs(interp, "properties", cfgClsNs, + TclOODefinePropertyCmd, INT2PTR(0) /*useInstance*/, NULL); + Tcl_Export(interp, cfgClsNs, "property", /*reset*/1); + TclSetNsPath((Namespace *) cfgClsNs, 1, &defineNs); + + // 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'. + Object *configurableObj = (Object *) Tcl_NewObjectInstance(interp, + (Tcl_Class) fPtr->classCls, "::oo::configurable", + NULL, TCL_INDEX_NONE, NULL, 0); + Class *configurableCls = configurableObj->classPtr; + MarkAsMetaclass(fPtr, configurableCls); + Tcl_ClassSetConstructor(interp, (Tcl_Class) configurableCls, TclNewMethod( + (Tcl_Class) configurableCls, NULL, 0, &configurableConstructor, NULL)); + + Tcl_Obj *nsName = Tcl_NewStringObj("::oo::configuresupport::configurableclass", + TCL_AUTO_LENGTH); + Tcl_IncrRefCount(nsName); + if (cfgSupCls->clsDefinitionNs != NULL) { + Tcl_DecrRefCount(cfgSupCls->clsDefinitionNs); + } + cfgSupCls->clsDefinitionNs = nsName; + Tcl_IncrRefCount(nsName); + if (configurableCls->clsDefinitionNs != NULL) { + Tcl_DecrRefCount(configurableCls->clsDefinitionNs); + } + configurableCls->clsDefinitionNs = nsName; + + nsName = Tcl_NewStringObj("::oo::configuresupport::configurableobject", + TCL_AUTO_LENGTH); + Tcl_IncrRefCount(nsName); + if (cfgSupCls->objDefinitionNs != NULL) { + Tcl_DecrRefCount(cfgSupCls->objDefinitionNs); + } + cfgSupCls->objDefinitionNs = nsName; +} + /* * ---------------------------------------------------------------------- * diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 740e2cb..36f2736 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -23,6 +23,8 @@ static Tcl_NRPostProc PostClassConstructor; static Tcl_NRPostProc FinalizeConstruction; static Tcl_NRPostProc FinalizeEval; static Tcl_NRPostProc NextRestoreFrame; +static Tcl_NRPostProc MarkAsSingleton; +static Tcl_NRPostProc UpdateClassDelegatesAfterClone; /* * ---------------------------------------------------------------------- @@ -477,6 +479,138 @@ TclOO_Class_New( /* * ---------------------------------------------------------------------- * + * TclOO_Class_Cloned -- + * + * Handler for cloning classes, which fixes up the delegates. This allows + * the clone's class methods to evolve independently of the origin's + * class methods; this is how TclOO works by default. + * + * ---------------------------------------------------------------------- + */ +int +TclOO_Class_Cloned( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Interpreter in which to create the object; + * also used for error reporting. */ + Tcl_ObjectContext context, /* The object/call context. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* The actual arguments. */ +{ + Tcl_Object targetObject = Tcl_ObjectContextObject(context); + Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context); + if (skip >= objc) { + Tcl_WrongNumArgs(interp, skip, objv, "originObject"); + return TCL_ERROR; + } + Tcl_Object originObject = Tcl_GetObjectFromObj(interp, objv[skip]); + if (!originObject) { + return TCL_ERROR; + } + // Add references so things won't vanish until after + // UpdateClassDelegatesAfterClone is finished with them. + AddRef((Object *) originObject); + AddRef((Object *) targetObject); + TclNRAddCallback(interp, UpdateClassDelegatesAfterClone, + originObject, targetObject, NULL, NULL); + return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip); +} + +// Rebuilds the class inheritance delegation class. +static int +UpdateClassDelegatesAfterClone( + void *data[], + Tcl_Interp *interp, + int result) +{ + Object *originPtr = (Object *) data[0]; + Object *targetPtr = (Object *) data[1]; + if (result == TCL_OK && originPtr->classPtr && targetPtr->classPtr) { + // Get the originating delegate to be cloned. + + Tcl_Obj *originName = Tcl_ObjPrintf("%s:: oo ::delegate", + originPtr->namespacePtr->fullName); + Object *originDelegate = (Object *) Tcl_GetObjectFromObj(interp, + originName); + Tcl_BounceRefCount(originName); + // Delegates never have their own delegates, so silently make sure we + // don't try to make a clone of them. + if (!(originDelegate && originDelegate->classPtr)) { + goto noOriginDelegate; + } + + // Create the cloned target delegate. + + Tcl_Obj *targetName = Tcl_ObjPrintf("%s:: oo ::delegate", + targetPtr->namespacePtr->fullName); + Object *targetDelegate = (Object *) Tcl_CopyObjectInstance(interp, + (Tcl_Object) originDelegate, Tcl_GetString(targetName), NULL); + Tcl_BounceRefCount(targetName); + if (targetDelegate == NULL) { + result = TCL_ERROR; + goto noOriginDelegate; + } + + // Point the cloned target class at the cloned target delegate. + // This is like TclOOObjectSetMixins() but more efficient in this + // case as there's definitely no relevant call chains to invalidate + // and we're doing a one-for-one replacement. + + Tcl_Size i; + Class *mixin; + FOREACH(mixin, targetPtr->mixins) { + if (mixin == originDelegate->classPtr) { + TclOORemoveFromInstances(targetPtr, originDelegate->classPtr); + TclOODecrRefCount(originDelegate); + targetPtr->mixins.list[i] = targetDelegate->classPtr; + TclOOAddToInstances(targetPtr, targetDelegate->classPtr); + AddRef(targetDelegate); + break; + } + } + } + noOriginDelegate: + TclOODecrRefCount(originPtr); + TclOODecrRefCount(targetPtr); + return result; +}; + +/* + * ---------------------------------------------------------------------- + * + * TclOO_Configurable_Constructor -- + * + * Implementation for oo::configurable constructor. + * + * ---------------------------------------------------------------------- + */ +int +TclOO_Configurable_Constructor( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context); + if (objc != skip && objc != skip + 1) { + Tcl_WrongNumArgs(interp, skip, objv, "?definitionScript?"); + return TCL_ERROR; + } + Tcl_Obj *cfgSupportName = Tcl_NewStringObj( + "::oo::configuresupport::configurable", TCL_AUTO_LENGTH); + Class *mixin = TclOOGetClassFromObj(interp, cfgSupportName); + Tcl_BounceRefCount(cfgSupportName); + if (!mixin) { + return TCL_ERROR; + } + TclOOClassSetMixins(interp, oPtr->classPtr, 1, &mixin); + return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip); +} + +/* + * ---------------------------------------------------------------------- + * * TclOO_Object_Destroy -- * * Implementation for oo::object->destroy method. @@ -1777,6 +1911,88 @@ TclOODelegateNameObjCmd( return TCL_OK; } +int +TclOO_Singleton_New( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Interpreter in which to create the object; + * also used for error reporting. */ + Tcl_ObjectContext context, /* The object/call context. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* The actual arguments. */ +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Class *clsPtr = oPtr->classPtr; + + if (clsPtr->instances.num) { + Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->instances.list[0])); + return TCL_OK; + } + + TclNRAddCallback(interp, MarkAsSingleton, clsPtr, NULL, NULL, NULL); + return TclNRNewObjectInstance(interp, (Tcl_Class) clsPtr, + NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context), + AddConstructionFinalizer(interp)); +} + +static int +MarkAsSingleton( + void *data[], + Tcl_Interp *interp, + int result) +{ + Class *clsPtr = (Class *) data[0]; + if (result == TCL_OK && clsPtr->instances.num) { + // Prepend oo::SingletonInstance to the list of mixins + Tcl_Obj *singletonInstanceName = Tcl_NewStringObj( + "::oo::SingletonInstance", TCL_AUTO_LENGTH); + Class *singInst = TclOOGetClassFromObj(interp, singletonInstanceName); + Tcl_BounceRefCount(singletonInstanceName); + if (!singInst) { + return TCL_ERROR; + } + Object *oPtr = clsPtr->instances.list[0]; + Tcl_Size mixinc = oPtr->mixins.num; + Class **mixins = (Class **)TclStackAlloc(interp, + sizeof(Class *) * (mixinc + 1)); + if (mixinc > 0) { + memcpy(mixins + 1, oPtr->mixins.list, mixinc * sizeof(Class *)); + } + mixins[0] = singInst; + TclOOObjectSetMixins(oPtr, mixinc + 1, mixins); + TclStackFree(interp, mixins); + } + return result; +} + +int +TclOO_SingletonInstance_Destroy( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Interpreter for error reporting. */ + TCL_UNUSED(Tcl_ObjectContext), + TCL_UNUSED(int), + TCL_UNUSED(Tcl_Obj *const *)) +{ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "may not destroy a singleton object")); + OO_ERROR(interp, SINGLETON); + return TCL_ERROR; +} + +int +TclOO_SingletonInstance_Cloned( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Interpreter in which to create the object; + * also used for error reporting. */ + TCL_UNUSED(Tcl_ObjectContext), + TCL_UNUSED(int), + TCL_UNUSED(Tcl_Obj *const *)) +{ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "may not clone a singleton object")); + OO_ERROR(interp, SINGLETON); + return TCL_ERROR; +} + /* * Local Variables: * mode: c diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 3fe4799..a2082b3 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1340,6 +1340,48 @@ UnexportInstanceMethod( } return isNew; } + +int +TclOOExportMethods( + Class *clsPtr, + ...) +{ + va_list argList; + int changed = 0; + va_start(argList, clsPtr); + while (1) { + const char *name = va_arg(argList, char *); + if (!name) { + break; + } + Tcl_Obj *namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); + changed |= ExportMethod(clsPtr, namePtr); + Tcl_BounceRefCount(namePtr); + } + va_end(argList); + return changed; +} + +int +TclOOUnexportMethods( + Class *clsPtr, + ...) +{ + va_list argList; + int changed = 0; + va_start(argList, clsPtr); + while (1) { + const char *name = va_arg(argList, char *); + if (!name) { + break; + } + Tcl_Obj *namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); + changed |= UnexportMethod(clsPtr, namePtr); + Tcl_BounceRefCount(namePtr); + } + va_end(argList); + return changed; +} /* * ---------------------------------------------------------------------- @@ -3147,6 +3189,41 @@ Slot_Unknown( /* * ---------------------------------------------------------------------- * + * TclOOSetSuperclasses -- + * + * Core of the "superclass" slot setter. Caller must AddRef() the objects + * holding the classes to set before calling this. The 'superclasses' + * argument must be allocated with Tcl_Alloc(); this function takes + * ownership. + * + * ---------------------------------------------------------------------- + */ +void +TclOOSetSuperclasses( + Class *clsPtr, + Tcl_Size superc, + Class **superclasses) +{ + Tcl_Size i; + Class *superPtr; + + if (clsPtr->superclasses.num != 0) { + FOREACH(superPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); + } + Tcl_Free(clsPtr->superclasses.list); + } + clsPtr->superclasses.list = superclasses; + clsPtr->superclasses.num = superc; + FOREACH(superPtr, clsPtr->superclasses) { + TclOOAddToSubclasses(clsPtr, superPtr); + } +} + +/* + * ---------------------------------------------------------------------- + * * ClassFilter_Get, ClassFilter_Set -- * * Implementation of the "filter" slot accessors of the "oo::define" @@ -3376,7 +3453,6 @@ ClassSuper_Set( Tcl_Size superc, j; Tcl_Size i; Tcl_Obj **superv; - Class **superclasses, *superPtr; if (clsPtr == NULL) { return TCL_ERROR; @@ -3403,7 +3479,7 @@ ClassSuper_Set( * Allocate some working space. */ - superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc); + Class **superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc); /* * Parse the arguments to get the class to use as superclasses. @@ -3466,18 +3542,7 @@ ClassSuper_Set( * subclass list. */ - if (clsPtr->superclasses.num != 0) { - FOREACH(superPtr, clsPtr->superclasses) { - TclOORemoveFromSubclasses(clsPtr, superPtr); - TclOODecrRefCount(superPtr->thisPtr); - } - Tcl_Free(clsPtr->superclasses.list); - } - clsPtr->superclasses.list = superclasses; - clsPtr->superclasses.num = superc; - FOREACH(superPtr, clsPtr->superclasses) { - TclOOAddToSubclasses(clsPtr, superPtr); - } + TclOOSetSuperclasses(clsPtr, superc, superclasses); BumpGlobalEpoch(interp, clsPtr); return TCL_OK; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 70b4a32..66ec7d1 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -533,6 +533,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOOInfoClassPropCmd; * Method implementations (in tclOOBasic.c). */ +MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Cloned; MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Constructor; MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_Create; MODULE_SCOPE Tcl_MethodCallProc TclOO_Class_CreateNs; @@ -543,6 +544,10 @@ MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_LinkVar; MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_Unknown; MODULE_SCOPE Tcl_MethodCallProc TclOO_Object_VarName; MODULE_SCOPE Tcl_MethodCallProc TclOO_Configurable_Configure; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Configurable_Constructor; +MODULE_SCOPE Tcl_MethodCallProc TclOO_Singleton_New; +MODULE_SCOPE Tcl_MethodCallProc TclOO_SingletonInstance_Cloned; +MODULE_SCOPE Tcl_MethodCallProc TclOO_SingletonInstance_Destroy; /* * Private definitions, some of which perhaps ought to be exposed properly or @@ -583,6 +588,7 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); +MODULE_SCOPE int TclOOExportMethods(Class *clsPtr, ...); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Object *contextObjPtr, Class *contextClsPtr, @@ -628,11 +634,14 @@ MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, CallChain *callPtr); +MODULE_SCOPE void TclOOSetSuperclasses(Class *clsPtr, Tcl_Size superc, + Class **superclasses); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); +MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); +MODULE_SCOPE int TclOOUnexportMethods(Class *clsPtr, ...); MODULE_SCOPE Tcl_Obj * TclOOGetAllObjectProperties(Object *oPtr, int writable); -MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); MODULE_SCOPE Tcl_Obj * TclOOGetPropertyList(PropertyList *propList); MODULE_SCOPE void TclOOReleasePropertyStorage(PropertyStorage *propsPtr); MODULE_SCOPE void TclOOInstallReadableProperties(PropertyStorage *props, diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 390b034..24a3255 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -26,94 +26,32 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ -"::namespace eval ::oo {\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" -"\t\t\tforeach a $args {\n" -"\t\t\t\tif {[info default $p $a d]} {\n" -"\t\t\t\t\tlset args [incr idx] [list $a $d]\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\tlset args [incr idx] [list $a]\n" -"\t\t\t\t}\n" +"::oo::define ::oo::object method -unexport {originObject} {\n" +"\tforeach p [info procs [info object namespace $originObject]::*] {\n" +"\t\tset args [info args $p]\n" +"\t\tset idx -1\n" +"\t\tforeach a $args {\n" +"\t\t\tif {[info default $p $a d]} {\n" +"\t\t\t\tlset args [incr idx] [list $a $d]\n" +"\t\t\t} else {\n" +"\t\t\t\tlset args [incr idx] [list $a]\n" "\t\t\t}\n" -"\t\t\tset b [info body $p]\n" -"\t\t\tset p [namespace tail $p]\n" -"\t\t\tproc $p $args $b\n" -"\t\t}\n" -"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n" -"\t\t\tupvar 0 $v vOrigin\n" -"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" -"\t\t\tif {[info exists vOrigin]} {\n" -"\t\t\t\tif {[array exists vOrigin]} {\n" -"\t\t\t\t\tarray set vNew [array get vOrigin]\n" -"\t\t\t\t} else {\n" -"\t\t\t\t\tset vNew $vOrigin\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t}\n" -"\t}\n" -"\tdefine class method -unexport {originObject} {\n" -"\t\tset targetObject [self]\n" -"\t\tnext $originObject\n" -"\t\tset originDelegate [::oo::DelegateName $originObject]\n" -"\t\tset targetDelegate [::oo::DelegateName $targetObject]\n" -"\t\tif {\n" -"\t\t\t[info object isa class $originDelegate]\n" -"\t\t\t&& ![info object isa class $targetDelegate]\n" -"\t\t} then {\n" -"\t\t\t::oo::copy $originDelegate $targetDelegate\n" -"\t\t\t::oo::objdefine $targetObject mixin -set \\\n" -"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" -"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" -"\t\t\t\t}]\n" "\t\t}\n" +"\t\tset b [info body $p]\n" +"\t\tset p [namespace tail $p]\n" +"\t\tproc $p $args $b\n" "\t}\n" -"\tclass create singleton\n" -"\tdefine singleton superclass -set class\n" -"\tdefine singleton unexport create createWithNamespace\n" -"\tdefine singleton method new args {\n" -"\t\tvariable object\n" -"\t\tif {![info exists object] || ![info object isa object $object]} {\n" -"\t\t\tset object [next {*}$args]\n" -"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n" +"\tforeach v [info vars [info object namespace $originObject]::*] {\n" +"\t\tupvar 0 $v vOrigin\n" +"\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" +"\t\tif {[info exists vOrigin]} {\n" +"\t\t\tif {[array exists vOrigin]} {\n" +"\t\t\t\tarray set vNew [array get vOrigin]\n" +"\t\t\t} else {\n" +"\t\t\t\tset vNew $vOrigin\n" +"\t\t\t}\n" "\t\t}\n" -"\t\treturn $object\n" -"\t}\n" -"\tclass create SingletonInstance\n" -"\tdefine SingletonInstance method destroy {} {\n" -"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\"may not destroy a singleton object\"\n" -"\t}\n" -"\tdefine SingletonInstance method -unexport {originObject} {\n" -"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\"may not clone a singleton object\"\n" -"\t}\n" -"\tclass create abstract\n" -"\tdefine abstract superclass -set class\n" -"\tdefine abstract unexport create createWithNamespace new\n" -"\tnamespace eval configuresupport::configurableclass {\n" -"\t\t::proc properties args {::tailcall property {*}$args}\n" -"\t\t::namespace path ::oo::define\n" -"\t\t::namespace export property\n" -"\t}\n" -"\tnamespace eval configuresupport::configurableobject {\n" -"\t\t::proc properties args {::tailcall property {*}$args}\n" -"\t\t::namespace path ::oo::objdefine\n" -"\t\t::namespace export property\n" -"\t}\n" -"\tdefine configuresupport::configurable {\n" -"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" -"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" -"\t}\n" -"\tclass create configurable\n" -"\tdefine configurable superclass -set class\n" -"\tdefine configurable constructor {{definitionScript \"\"}} {\n" -"\t\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n" -"\t\tnext $definitionScript\n" "\t}\n" -"\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/tests/oo.test b/tests/oo.test index 21c8f9e..165ddae 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -378,10 +378,17 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { } -body { lmap x [$fresh eval { set initials {::oo::object ::oo::class ::oo::Slot} - foreach cmd {instances subclasses mixins superclass} { - foreach initial $initials { - lappend x [info class $cmd $initial] - } + foreach initial $initials { + lappend x [info class instances $initial] + } + foreach initial $initials { + lappend x [info class subclasses $initial] + } + foreach initial $initials { + lappend x [info class mixins $initial] + } + foreach initial $initials { + lappend x [info class superclasses $initial] } foreach initial $initials { lappend x [info object class $initial] @@ -390,7 +397,21 @@ 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::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} +} -result [list {*}{ + {} + {::oo::SingletonInstance ::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::SingletonInstance ::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-1.22 {basic test of OO functionality: nested ownership destruction order} -setup { oo::class create parent } -body { diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index b17d7d0..ef2d325 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -11,215 +11,47 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -::namespace eval ::oo { - # ---------------------------------------------------------------------- - # - # oo::object -- - # - # Handler for cloning objects that clones basic bits (only!) of the - # object's namespace. Non-procedures, traces, sub-namespaces, etc. need - # more complex (and class-specific) handling. - # - # ---------------------------------------------------------------------- - - 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] - set idx -1 - foreach a $args { - if {[info default $p $a d]} { - lset args [incr idx] [list $a $d] - } else { - lset args [incr idx] [list $a] - } +# ---------------------------------------------------------------------- +# +# oo::object -- +# +# Handler for cloning objects that clones basic bits (only!) of the +# object's namespace. Non-procedures, traces, sub-namespaces, etc. need +# more complex (and class-specific) handling. +# +# ---------------------------------------------------------------------- + +::oo::define ::oo::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] + set idx -1 + foreach a $args { + if {[info default $p $a d]} { + lset args [incr idx] [list $a $d] + } else { + lset args [incr idx] [list $a] } - set b [info body $p] - set p [namespace tail $p] - proc $p $args $b } - # Copy over the variables from the original namespace - foreach v [info vars [info object namespace $originObject]::*] { - upvar 0 $v vOrigin - namespace upvar [namespace current] [namespace tail $v] vNew - if {[info exists vOrigin]} { - if {[array exists vOrigin]} { - array set vNew [array get vOrigin] - } else { - set vNew $vOrigin - } + set b [info body $p] + set p [namespace tail $p] + proc $p $args $b + } + # Copy over the variables from the original namespace + foreach v [info vars [info object namespace $originObject]::*] { + upvar 0 $v vOrigin + namespace upvar [namespace current] [namespace tail $v] vNew + if {[info exists vOrigin]} { + if {[array exists vOrigin]} { + array set vNew [array get vOrigin] + } else { + set vNew $vOrigin } } - # General commands, sub-namespaces and advancd variable config (traces, - # etc) are *not* copied over. Classes that want that should do it - # themselves. - } - - # ---------------------------------------------------------------------- - # - # oo::class -- - # - # Handler for cloning classes, which fixes up the delegates. - # - # ---------------------------------------------------------------------- - - define class method -unexport {originObject} { - set targetObject [self] - next $originObject - # Rebuild the class inheritance delegation class - set originDelegate [::oo::DelegateName $originObject] - set targetDelegate [::oo::DelegateName $targetObject] - if { - [info object isa class $originDelegate] - && ![info object isa class $targetDelegate] - } then { - ::oo::copy $originDelegate $targetDelegate - ::oo::objdefine $targetObject mixin -set \ - {*}[lmap c [info object mixin $targetObject] { - if {$c eq $originDelegate} {set targetDelegate} {set c} - }] - } - } - - # ---------------------------------------------------------------------- - # - # oo::singleton -- - # - # A metaclass that is used to make classes that only permit one instance - # of them to exist. See singleton(n). - # - # ---------------------------------------------------------------------- - - class create singleton - define singleton superclass -set class - define singleton unexport create createWithNamespace - define singleton method new args { - variable object - if {![info exists object] || ![info object isa object $object]} { - set object [next {*}$args] - ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance - } - return $object - } - - # ---------------------------------------------------------------------- - # - # oo::SingletonInstance -- - # - # A mixin used to make an object so it won't be destroyed or cloned (or - # at least not easily). - # - # ---------------------------------------------------------------------- - - class create SingletonInstance - define SingletonInstance method destroy {} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - define SingletonInstance method -unexport {originObject} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" } - - # ---------------------------------------------------------------------- - # - # oo::abstract -- - # - # A metaclass that is used to make classes that can't be directly - # instantiated. See abstract(n). - # - # ---------------------------------------------------------------------- - - class create abstract - define abstract superclass -set class - define abstract unexport create createWithNamespace new - - # ---------------------------------------------------------------------- - # - # oo::configuresupport -- - # - # Namespace that holds all the implementation details of TIP #558. - # Also includes the commands: - # - # * readableproperties - # * writableproperties - # * objreadableproperties - # * objwritableproperties - # - # These are all slot implementations that provide access to the C layer - # of property support (i.e., very fast cached lookup of property names). - # - # * StdClassProperties - # * StdObjectPropertes - # - # These cause very fast basic implementation methods for a property - # following the standard model of property implementation naming. - # Property schemes that use other models (such as to be more Tk-like) - # should not use these (or the oo::cconfigurable metaclass). - # - # ---------------------------------------------------------------------- - - # ------------------------------------------------------------------ - # - # oo::configuresupport::configurableclass, - # oo::configuresupport::configurableobject -- - # - # Namespaces used as implementation vectors for oo::define and - # oo::objdefine when the class/instance is configurable. - # Note that these also contain commands implemented in C, - # especially the [property] definition command. - # - # ------------------------------------------------------------------ - - namespace eval configuresupport::configurableclass { - # Plural alias just in case; deliberately NOT documented! - ::proc properties args {::tailcall property {*}$args} - ::namespace path ::oo::define - ::namespace export property - } - - namespace eval configuresupport::configurableobject { - # Plural alias just in case; deliberately NOT documented! - ::proc properties args {::tailcall property {*}$args} - ::namespace path ::oo::objdefine - ::namespace export property - } - - # ------------------------------------------------------------------ - # - # oo::configuresupport::configurable -- - # - # The class that contains the implementation of the actual - # 'configure' method (mixed into actually configurable classes). - # The 'configure' method is in tclOOBasic.c. - # - # ------------------------------------------------------------------ - - define configuresupport::configurable { - definitionnamespace -instance configuresupport::configurableobject - definitionnamespace -class configuresupport::configurableclass - } - - # ---------------------------------------------------------------------- - # - # oo::configurable -- - # - # 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'. - # - # ---------------------------------------------------------------------- - - class create configurable - define configurable superclass -set class - define configurable constructor {{definitionScript ""}} { - ::oo::define [self] {mixin -append ::oo::configuresupport::configurable} - next $definitionScript - } - - define configurable definitionnamespace -class configuresupport::configurableclass + # General commands, sub-namespaces and advancd variable config (traces, + # etc) are *not* copied over. Classes that want that should do it + # themselves. } # Local Variables: -- cgit v0.12 From 188c4a20f462155ac0c5acf05f1bf6e28bd42a86 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 28 Aug 2025 14:54:14 +0000 Subject: Modify code and comments for 9.0 style --- generic/tclOO.c | 101 ++++++++++++++++++++++++++-------------------- generic/tclOOBasic.c | 58 ++++++++++++++------------ generic/tclOODefineCmds.c | 42 ++++++++++--------- 3 files changed, 114 insertions(+), 87 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 4ebcf77..2e84bf8 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -625,43 +625,62 @@ MakeAdditionalClasses( Tcl_Namespace *objDefineNs) { Tcl_Interp *interp = fPtr->interp; - - /* - * Make the singleton class, the SingletonInstance class, and install their - * standard defined methods. - */ - - // A metaclass that is used to make classes that only permit one instance - // of them to exist. See singleton(n). - Object *singletonObj = (Object *) Tcl_NewObjectInstance(interp, + Object *singletonObj; /* A metaclass that is used to make classes + * that only permit one instance of them to + * exist. See singleton(n). */ + Object *singletonInst; /* A mixin used to make an object so it won't + * be destroyed or cloned (or at least not + * easily). */ + Object *abstractCls; /* A metaclass that is used to make classes + * that can't be directly instantiated. See + * abstract(n). */ + Object *cfgSupObj; /* The class that contains the implementation + * of the actual 'configure' method (mixed into + * actually configurable classes). The + * 'configure' method is in tclOOBasic.c. */ + Object *configurableObj; /* 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'. */ + Class *singletonCls, *cfgSupCls, *configurableCls; + Tcl_Namespace *cfgObjNs, *cfgClsNs; + Tcl_Obj *nsName; + + /* + * Make the oo::singleton class, the SingletonInstance class, and install + * their standard defined methods. + */ + + singletonObj = (Object *) Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::singleton", NULL, TCL_INDEX_NONE, NULL, 0); - Class *singletonCls = singletonObj->classPtr; + singletonCls = singletonObj->classPtr; TclOODefineBasicMethods(singletonCls, singletonMethods); - // Set the superclass to oo::class + /* Set the superclass to oo::class */ MarkAsMetaclass(fPtr, singletonCls); - // Unexport methods + /* Unexport methods */ TclOOUnexportMethods(singletonCls, "create", "createWithNamespace", NULL); - // A mixin used to make an object so it won't be destroyed or cloned (or - // at least not easily). - Object *singletonInst = (Object *) Tcl_NewObjectInstance(interp, + singletonInst = (Object *) Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::SingletonInstance", NULL, TCL_INDEX_NONE, NULL, 0); TclOODefineBasicMethods(singletonInst->classPtr, singletonInstanceMethods); /* - * Make the abstract class. + * Make the oo::abstract class. */ - // A metaclass that is used to make classes that can't be directly - // instantiated. See abstract(n). - Object *abstractCls = (Object *) Tcl_NewObjectInstance(interp, + abstractCls = (Object *) Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::abstract", NULL, TCL_INDEX_NONE, NULL, 0); - // Set the superclass to oo::class + /* Set the superclass to oo::class */ MarkAsMetaclass(fPtr, abstractCls->classPtr); - // Unexport methods + /* Unexport methods */ TclOOUnexportMethods(abstractCls->classPtr, "create", "createWithNamespace", "new", NULL); @@ -669,21 +688,18 @@ MakeAdditionalClasses( * Make the configurable class and install its standard defined method. */ - // The class that contains the implementation of the actual - // 'configure' method (mixed into actually configurable classes). - // The 'configure' method is in tclOOBasic.c. - Object *cfgSupObj = (Object *) Tcl_NewObjectInstance(interp, + cfgSupObj = (Object *) Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::configuresupport::configurable", NULL, TCL_INDEX_NONE, NULL, 0); - Class *cfgSupCls = cfgSupObj->classPtr; + cfgSupCls = cfgSupObj->classPtr; TclOODefineBasicMethods(cfgSupCls, cfgMethods); - // Namespaces used as implementation vectors for oo::define and - // oo::objdefine when the class/instance is configurable. - // Note that these also contain commands implemented in C, - // especially the [property] definition command. + /* Namespaces used as implementation vectors for oo::define and + * oo::objdefine when the class/instance is configurable. + * Note that these also contain commands implemented in C, + * especially the [property] definition command. */ - Tcl_Namespace *cfgObjNs = Tcl_CreateNamespace(interp, + cfgObjNs = Tcl_CreateNamespace(interp, "::oo::configuresupport::configurableobject", NULL, NULL); TclCreateObjCommandInNs(interp, "property", cfgObjNs, TclOODefinePropertyCmd, INT2PTR(1) /*useInstance*/, NULL); @@ -692,7 +708,7 @@ MakeAdditionalClasses( Tcl_Export(interp, cfgObjNs, "property", /*reset*/1); TclSetNsPath((Namespace *) cfgObjNs, 1, &objDefineNs); - Tcl_Namespace *cfgClsNs = Tcl_CreateNamespace(interp, + cfgClsNs = Tcl_CreateNamespace(interp, "::oo::configuresupport::configurableclass", NULL, NULL); TclCreateObjCommandInNs(interp, "property", cfgClsNs, TclOODefinePropertyCmd, INT2PTR(0) /*useInstance*/, NULL); @@ -701,21 +717,21 @@ MakeAdditionalClasses( Tcl_Export(interp, cfgClsNs, "property", /*reset*/1); TclSetNsPath((Namespace *) cfgClsNs, 1, &defineNs); - // 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'. - Object *configurableObj = (Object *) Tcl_NewObjectInstance(interp, + /* The oo::configurable class itself, a metaclass to apply + * oo::configuresupport::configurable correctly. */ + + configurableObj = (Object *) Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::configurable", NULL, TCL_INDEX_NONE, NULL, 0); - Class *configurableCls = configurableObj->classPtr; + configurableCls = configurableObj->classPtr; MarkAsMetaclass(fPtr, configurableCls); Tcl_ClassSetConstructor(interp, (Tcl_Class) configurableCls, TclNewMethod( (Tcl_Class) configurableCls, NULL, 0, &configurableConstructor, NULL)); - Tcl_Obj *nsName = Tcl_NewStringObj("::oo::configuresupport::configurableclass", - TCL_AUTO_LENGTH); + /* Set the definition namespaces of oo::configurable and + * oo::configuresupport::configurable. */ + + nsName = TclNewNamespaceObj(cfgClsNs); Tcl_IncrRefCount(nsName); if (cfgSupCls->clsDefinitionNs != NULL) { Tcl_DecrRefCount(cfgSupCls->clsDefinitionNs); @@ -727,8 +743,7 @@ MakeAdditionalClasses( } configurableCls->clsDefinitionNs = nsName; - nsName = Tcl_NewStringObj("::oo::configuresupport::configurableobject", - TCL_AUTO_LENGTH); + nsName = TclNewNamespaceObj(cfgObjNs); Tcl_IncrRefCount(nsName); if (cfgSupCls->objDefinitionNs != NULL) { Tcl_DecrRefCount(cfgSupCls->objDefinitionNs); diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 36f2736..030d497 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -506,8 +506,8 @@ TclOO_Class_Cloned( if (!originObject) { return TCL_ERROR; } - // Add references so things won't vanish until after - // UpdateClassDelegatesAfterClone is finished with them. + /* Add references so things won't vanish until after + * UpdateClassDelegatesAfterClone is finished with them. */ AddRef((Object *) originObject); AddRef((Object *) targetObject); TclNRAddCallback(interp, UpdateClassDelegatesAfterClone, @@ -515,7 +515,7 @@ TclOO_Class_Cloned( return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip); } -// Rebuilds the class inheritance delegation class. +/* Rebuilds the class inheritance delegation class. */ static int UpdateClassDelegatesAfterClone( void *data[], @@ -525,24 +525,28 @@ UpdateClassDelegatesAfterClone( Object *originPtr = (Object *) data[0]; Object *targetPtr = (Object *) data[1]; if (result == TCL_OK && originPtr->classPtr && targetPtr->classPtr) { - // Get the originating delegate to be cloned. + Tcl_Obj *originName, *targetName; + Object *originDelegate, *targetDelegate; + Tcl_Size i; + Class *mixin; - Tcl_Obj *originName = Tcl_ObjPrintf("%s:: oo ::delegate", + /* Get the originating delegate to be cloned. */ + + originName = Tcl_ObjPrintf("%s:: oo ::delegate", originPtr->namespacePtr->fullName); - Object *originDelegate = (Object *) Tcl_GetObjectFromObj(interp, - originName); + originDelegate = (Object *) Tcl_GetObjectFromObj(interp, originName); Tcl_BounceRefCount(originName); - // Delegates never have their own delegates, so silently make sure we - // don't try to make a clone of them. + /* Delegates never have their own delegates, so silently make sure we + * don't try to make a clone of them. */ if (!(originDelegate && originDelegate->classPtr)) { goto noOriginDelegate; } - // Create the cloned target delegate. + /* Create the cloned target delegate. */ - Tcl_Obj *targetName = Tcl_ObjPrintf("%s:: oo ::delegate", + targetName = Tcl_ObjPrintf("%s:: oo ::delegate", targetPtr->namespacePtr->fullName); - Object *targetDelegate = (Object *) Tcl_CopyObjectInstance(interp, + targetDelegate = (Object *) Tcl_CopyObjectInstance(interp, (Tcl_Object) originDelegate, Tcl_GetString(targetName), NULL); Tcl_BounceRefCount(targetName); if (targetDelegate == NULL) { @@ -550,13 +554,11 @@ UpdateClassDelegatesAfterClone( goto noOriginDelegate; } - // Point the cloned target class at the cloned target delegate. - // This is like TclOOObjectSetMixins() but more efficient in this - // case as there's definitely no relevant call chains to invalidate - // and we're doing a one-for-one replacement. + /* Point the cloned target class at the cloned target delegate. + * This is like TclOOObjectSetMixins() but more efficient in this + * case as there's definitely no relevant call chains to invalidate + * and we're doing a one-for-one replacement. */ - Tcl_Size i; - Class *mixin; FOREACH(mixin, targetPtr->mixins) { if (mixin == originDelegate->classPtr) { TclOORemoveFromInstances(targetPtr, originDelegate->classPtr); @@ -593,13 +595,16 @@ TclOO_Configurable_Constructor( { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context); + Tcl_Obj *cfgSupportName; + Class *mixin; + if (objc != skip && objc != skip + 1) { Tcl_WrongNumArgs(interp, skip, objv, "?definitionScript?"); return TCL_ERROR; } - Tcl_Obj *cfgSupportName = Tcl_NewStringObj( + cfgSupportName = Tcl_NewStringObj( "::oo::configuresupport::configurable", TCL_AUTO_LENGTH); - Class *mixin = TclOOGetClassFromObj(interp, cfgSupportName); + mixin = TclOOGetClassFromObj(interp, cfgSupportName); Tcl_BounceRefCount(cfgSupportName); if (!mixin) { return TCL_ERROR; @@ -1942,18 +1947,21 @@ MarkAsSingleton( { Class *clsPtr = (Class *) data[0]; if (result == TCL_OK && clsPtr->instances.num) { - // Prepend oo::SingletonInstance to the list of mixins + /* Prepend oo::SingletonInstance to the list of mixins */ Tcl_Obj *singletonInstanceName = Tcl_NewStringObj( "::oo::SingletonInstance", TCL_AUTO_LENGTH); Class *singInst = TclOOGetClassFromObj(interp, singletonInstanceName); + Object *oPtr; + Tcl_Size mixinc; + Class **mixins; + Tcl_BounceRefCount(singletonInstanceName); if (!singInst) { return TCL_ERROR; } - Object *oPtr = clsPtr->instances.list[0]; - Tcl_Size mixinc = oPtr->mixins.num; - Class **mixins = (Class **)TclStackAlloc(interp, - sizeof(Class *) * (mixinc + 1)); + oPtr = clsPtr->instances.list[0]; + mixinc = oPtr->mixins.num; + mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * (mixinc + 1)); if (mixinc > 0) { memcpy(mixins + 1, oPtr->mixins.list, mixinc * sizeof(Class *)); } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index a2082b3..796ae37 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,7 +37,7 @@ typedef struct DeclaredSlot { const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; - const char *defaultOp; // The default op, if not set by the class + const char *defaultOp; /* The default op, if not set by the class */ } DeclaredSlot; #define SLOT(name,getter,setter,resolver,defOp) \ @@ -1256,6 +1256,7 @@ GetOrCreateMethod( isNew); if (*isNew) { Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = namePtr; @@ -1351,10 +1352,12 @@ TclOOExportMethods( va_start(argList, clsPtr); while (1) { const char *name = va_arg(argList, char *); + Tcl_Obj *namePtr; + if (!name) { break; } - Tcl_Obj *namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); + namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); changed |= ExportMethod(clsPtr, namePtr); Tcl_BounceRefCount(namePtr); } @@ -1372,10 +1375,12 @@ TclOOUnexportMethods( va_start(argList, clsPtr); while (1) { const char *name = va_arg(argList, char *); + Tcl_Obj *namePtr; + if (!name) { break; } - Tcl_Obj *namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); + namePtr = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); changed |= UnexportMethod(clsPtr, namePtr); Tcl_BounceRefCount(namePtr); } @@ -2095,17 +2100,19 @@ TclOODefineExportObjCmd( { int isInstanceExport = (clientData != NULL); int i, changed = 0; + Object *oPtr; + Class *clsPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } - Class *clsPtr = oPtr->classPtr; + clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", TCL_AUTO_LENGTH)); @@ -2621,6 +2628,7 @@ TclOODefineSlots( Tcl_Class slotCls; const DeclaredSlotMethod *smPtr; const DeclaredSlot *slotPtr; + Tcl_Obj *defaults[2]; if (object == NULL) { return TCL_ERROR; @@ -2637,12 +2645,10 @@ TclOODefineSlots( Tcl_BounceRefCount(name); } - // If a slot can't figure out what method to call directly, it uses - // --default-operation. That defaults to -append; we set that here. - Tcl_Obj *defaults[] = { - fPtr->myName, - Tcl_NewStringObj("-append", TCL_AUTO_LENGTH) - }; + /* If a slot can't figure out what method to call directly, it uses + * --default-operation. That defaults to -append; we set that here. */ + defaults[0] = fPtr->myName; + defaults[1] = Tcl_NewStringObj("-append", TCL_AUTO_LENGTH); TclOONewForwardMethod(interp, (Class *) slotCls, 0, fPtr->slotDefOpName, Tcl_NewListObj(2, defaults)); @@ -2666,12 +2672,9 @@ TclOODefineSlots( &slotPtr->resolverType, NULL); } if (slotPtr->defaultOp) { - Tcl_Obj *slotDefaults[] = { - fPtr->myName, - Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH) - }; + defaults[1] = Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH); TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0, - fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults)); + fPtr->slotDefOpName, Tcl_NewListObj(2, defaults)); } } return TCL_OK; @@ -3449,10 +3452,12 @@ ClassSuper_Set( int objc, Tcl_Obj *const *objv) { + Foundation *fPtr; Class *clsPtr = TclOOGetClassDefineCmdContext(interp); Tcl_Size superc, j; Tcl_Size i; Tcl_Obj **superv; + Class **superclasses; if (clsPtr == NULL) { return TCL_ERROR; @@ -3463,7 +3468,7 @@ ClassSuper_Set( } objv += Tcl_ObjectContextSkippedArgs(context); - Foundation *fPtr = clsPtr->thisPtr->fPtr; + fPtr = clsPtr->thisPtr->fPtr; if (clsPtr == fPtr->objectCls) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not modify the superclass of the root object", @@ -3479,7 +3484,7 @@ ClassSuper_Set( * Allocate some working space. */ - Class **superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc); + superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * (superc ? superc : 1)); /* * Parse the arguments to get the class to use as superclasses. @@ -3489,7 +3494,6 @@ ClassSuper_Set( */ if (superc == 0) { - superclasses = (Class **) Tcl_Realloc(superclasses, sizeof(Class *)); if (TclOOIsReachable(fPtr->classCls, clsPtr)) { superclasses[0] = fPtr->classCls; } else { -- cgit v0.12