From d1d60243ce313f9106156751ae34ecd431cd1deb Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Jul 2024 21:42:43 +0000 Subject: Make the [property] definition itself go to C --- generic/tclOO.c | 10 +- generic/tclOODefineCmds.c | 354 ++++++++++++++++++++++++++++++++++++++++++---- generic/tclOOInt.h | 14 +- generic/tclOOScript.h | 92 +----------- tools/tclOOScript.tcl | 152 ++------------------ 5 files changed, 364 insertions(+), 258 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 5ceae4e..8ae30e9 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -441,9 +441,15 @@ InitFoundation( &cfgMethods[i]); } Tcl_CreateObjCommand(interp, "::oo::configuresupport::StdObjectProperties", - TclOOInstallStdPropertyImpls, (void *) 1, NULL); + TclOOInstallStdPropertyImplsCmd, (void *) 1, NULL); Tcl_CreateObjCommand(interp, "::oo::configuresupport::StdClassProperties", - TclOOInstallStdPropertyImpls, (void *) 0, NULL); + TclOOInstallStdPropertyImplsCmd, (void *) 0, NULL); + Tcl_CreateObjCommand(interp, + "::oo::configuresupport::configurableobject::property", + TclOOPropertyDefinitionCmd, (void *) 1, NULL); + Tcl_CreateObjCommand(interp, + "::oo::configuresupport::configurableclass::property", + TclOOPropertyDefinitionCmd, (void *) 0, NULL); /* * Evaluate the remaining definitions, which are a compiled-in Tcl script. diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 9e4f879..5f784d9 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -75,6 +75,9 @@ static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp, static inline int InitDefineContext(Tcl_Interp *interp, Tcl_Namespace *namespacePtr, Object *oPtr, int objc, Tcl_Obj *const objv[]); +static int InstallStdPropertyImpls(void *useInstance, + Tcl_Interp *interp, Tcl_Obj *propName, + int readable, int writable); static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, @@ -3487,7 +3490,286 @@ ObjWPropsSet( /* * ---------------------------------------------------------------------- * - * TclOOInstallStdPropertyImpls -- + * TclOORegisterProperty, TclOORegisterInstanceProperty -- + * + * Helpers to add or remove a name from the property slots of a class or + * instance. + * + * BuildPropertyList -- + * + * Helper for the helpers. Scans a property list and does the filtering + * or adding of the property to add or remove + * + * ---------------------------------------------------------------------- + */ + +static int +BuildPropertyList( + PropertyList *propsList, /* Property list to scan. */ + Tcl_Obj *propName, /* Property to add/remove. */ + int addingProp, /* True if we're adding, false if removing. */ + Tcl_Obj *listObj) /* The list of property names we're building */ +{ + int present = 0, changed = 0, i; + Tcl_Obj *other; + + Tcl_SetListObj(listObj, 0, NULL); + FOREACH(other, *propsList) { + if (strcmp(TclGetString(propName), TclGetString(other)) == 0) { + present = 1; + if (!addingProp) { + changed = 1; + continue; + } + } + Tcl_ListObjAppendElement(NULL, listObj, other); + } + if (!present && addingProp) { + Tcl_ListObjAppendElement(NULL, listObj, propName); + changed = 1; + } + return changed; +} + +void +TclOORegisterInstanceProperty( + Object *oPtr, /* Object that owns the property slots. */ + Tcl_Obj *propName, /* Property to add/remove. Must include the + * hyphen if one is desired; this is the value + * that is actually placed in the slot. */ + int registerReader, /* True if we're adding the property name to + * the readable property slot. False if we're + * removing the property name from the slot. */ + int registerWriter) /* True if we're adding the property name to + * the writable property slot. False if we're + * removing the property name from the slot. */ +{ + Tcl_Obj *listObj = Tcl_NewObj(); /* Working buffer. */ + Tcl_Obj **objv; + Tcl_Size count; + + if (BuildPropertyList(&oPtr->properties.readable, propName, registerReader, + listObj)) { + TclListObjGetElements(NULL, listObj, &count, &objv); + InstallReadableProps(&oPtr->properties, count, objv); + } + + if (BuildPropertyList(&oPtr->properties.writable, propName, registerWriter, + listObj)) { + TclListObjGetElements(NULL, listObj, &count, &objv); + InstallWritableProps(&oPtr->properties, count, objv); + } + Tcl_DecrRefCount(listObj); +} + +void +TclOORegisterProperty( + Class *clsPtr, /* Class that owns the property slots. */ + Tcl_Obj *propName, /* Property to add/remove. Must include the + * hyphen if one is desired; this is the value + * that is actually placed in the slot. */ + int registerReader, /* True if we're adding the property name to + * the readable property slot. False if we're + * removing the property name from the slot. */ + int registerWriter) /* True if we're adding the property name to + * the writable property slot. False if we're + * removing the property name from the slot. */ +{ + Tcl_Obj *listObj = Tcl_NewObj(); /* Working buffer. */ + Tcl_Obj **objv; + Tcl_Size count; + int changed = 0; + + if (BuildPropertyList(&clsPtr->properties.readable, propName, + registerReader, listObj)) { + TclListObjGetElements(NULL, listObj, &count, &objv); + InstallReadableProps(&clsPtr->properties, count, objv); + changed = 1; + } + + if (BuildPropertyList(&clsPtr->properties.writable, propName, + registerWriter, listObj)) { + TclListObjGetElements(NULL, listObj, &count, &objv); + InstallWritableProps(&clsPtr->properties, count, objv); + changed = 1; + } + Tcl_DecrRefCount(listObj); + if (changed) { + BumpGlobalEpoch(clsPtr->thisPtr->fPtr->interp, clsPtr); + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOOPropertyDefinitionCmd -- + * + * Implementation of the "property" definition for classes and instances + * governed by the [oo::configurable] metaclass. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOPropertyDefinitionCmd( + void *useInstance, /* NULL for class, non-NULL for object. */ + Tcl_Interp *interp, /* For error reporting and lookup. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Arguments. */ +{ + int i; + const char *const options[] = { + "-get", "-kind", "-set", NULL + }; + enum Options { + OPT_GET, OPT_KIND, OPT_SET + }; + const char *const kinds[] = { + "readable", "readwrite", "writable", NULL + }; + enum Kinds { + KIND_RO, KIND_RW, KIND_WO + }; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!useInstance && !oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL); + return TCL_ERROR; + } + + for (i = 1; i < objc; i++) { + Tcl_Obj *propObj = objv[i], *nextObj, *argObj, *hyphenated; + Tcl_Obj *getterScript = NULL, *setterScript = NULL; + + /* + * Parse the extra options for the property. + */ + + int kind = KIND_RW; + while (i + 1 < objc) { + int option; + + nextObj = objv[i + 1]; + if (TclGetString(nextObj)[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, nextObj, options, "option", 0, + &option) != TCL_OK) { + return TCL_ERROR; + } + if (i + 2 >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing %s to go with %s option", + (option == OPT_KIND ? "kind value" : "body"), + options[option])); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL); + return TCL_ERROR; + } + argObj = objv[i + 2]; + i += 2; + switch (option) { + case OPT_GET: + getterScript = argObj; + break; + case OPT_SET: + setterScript = argObj; + break; + case OPT_KIND: + if (Tcl_GetIndexFromObj(interp, argObj, kinds, "kind", 0, + &kind) != TCL_OK) { + return TCL_ERROR; + } + break; + } + } + + /* + * Install the property. Note that InstallStdPropertyImpls + * validates the property name as well. + */ + + if (InstallStdPropertyImpls(useInstance, interp, propObj, + kind != KIND_WO && getterScript == NULL, + kind != KIND_RO && setterScript == NULL) != TCL_OK) { + return TCL_ERROR; + } + + hyphenated = Tcl_ObjPrintf("-%s", TclGetString(propObj)); + Tcl_IncrRefCount(hyphenated); + if (useInstance) { + TclOORegisterInstanceProperty(oPtr, hyphenated, + kind != KIND_WO, kind != KIND_RO); + } else { + TclOORegisterProperty(oPtr->classPtr, hyphenated, + kind != KIND_WO, kind != KIND_RO); + } + Tcl_DecrRefCount(hyphenated); + + /* + * Create property implementation methods by using the right + * back-end API, but only if the user has given us the bodies of the + * methods we'll make. + */ + + if (getterScript != NULL) { + Tcl_Obj *getterName = Tcl_ObjPrintf("", + TclGetString(propObj)); + Tcl_Obj *argsPtr = Tcl_NewObj(); + Method *mPtr; + + Tcl_IncrRefCount(getterName); + Tcl_IncrRefCount(argsPtr); + Tcl_IncrRefCount(getterScript); + if (useInstance) { + mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0, + getterName, argsPtr, getterScript, NULL); + } else { + mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0, + getterName, argsPtr, getterScript, NULL); + } + Tcl_DecrRefCount(getterName); + Tcl_DecrRefCount(argsPtr); + Tcl_DecrRefCount(getterScript); + if (mPtr == NULL) { + return TCL_ERROR; + } + } + if (setterScript != NULL) { + Tcl_Obj *setterName = Tcl_ObjPrintf("", + TclGetString(propObj)); + Tcl_Obj *argsPtr = Tcl_NewStringObj("value", -1); + Method *mPtr; + + Tcl_IncrRefCount(setterName); + Tcl_IncrRefCount(argsPtr); + Tcl_IncrRefCount(setterScript); + if (useInstance) { + mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0, + setterName, argsPtr, setterScript, NULL); + } else { + mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0, + setterName, argsPtr, setterScript, NULL); + } + Tcl_DecrRefCount(setterName); + Tcl_DecrRefCount(argsPtr); + Tcl_DecrRefCount(setterScript); + if (mPtr == NULL) { + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InstallStdPropertyImpls, TclOOInstallStdPropertyImplsCmd -- * * Implementations of the "StdClassProperties" hidden definition for * classes and the "StdObjectProperties" hidden definition for @@ -3499,32 +3781,26 @@ ObjWPropsSet( * ---------------------------------------------------------------------- */ -int -TclOOInstallStdPropertyImpls( +static int +InstallStdPropertyImpls( void *useInstance, Tcl_Interp *interp, - int objc, - Tcl_Obj *const *objv) + Tcl_Obj *propName, + int readable, + int writable) { - int readable, writable; - Tcl_Obj *propName; const char *name, *reason; Tcl_Size len; char flag = TCL_DONT_QUOTE_HASH; /* - * Parse the arguments and validate the property name. Note that just - * calling TclScanElement() is cheaper than actually formatting a list - * and comparing the string version of that with the original, as - * TclScanElement() is one of the core parts of doing that; this skips - * a whole load of irrelevant memory allocations! + * Validate the property name. Note that just calling TclScanElement() is + * cheaper than actually formatting a list and comparing the string + * version of that with the original, as TclScanElement() is one of the + * core parts of doing that; this skips a whole load of irrelevant memory + * allocations! */ - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "propName readable writable"); - return TCL_ERROR; - } - propName = objv[1]; name = Tcl_GetStringFromObj(propName, &len); if (Tcl_StringMatch(name, "-*")) { reason = "must not begin with -"; @@ -3542,12 +3818,6 @@ TclOOInstallStdPropertyImpls( reason = "must not contain parentheses"; goto badProp; } - if (Tcl_GetBooleanFromObj(interp, objv[2], &readable) != TCL_OK) { - return TCL_ERROR; - } - if (Tcl_GetBooleanFromObj(interp, objv[3], &writable) != TCL_OK) { - return TCL_ERROR; - } /* * Install the implementations... if asked to do so. @@ -3572,7 +3842,43 @@ TclOOInstallStdPropertyImpls( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad property name \"%s\": %s", name, reason)); Tcl_SetErrorCode(interp, "TCL", "OO", "PROPERTY_FORMAT", NULL); - return TCL_ERROR; + return TCL_ERROR; +} + +int +TclOOInstallStdPropertyImplsCmd( + void *useInstance, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int readable, writable; + Tcl_Obj *propName; + + /* + * Parse the arguments. + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "propName readable writable"); + return TCL_ERROR; + } + propName = objv[1]; + if (Tcl_GetBooleanFromObj(interp, objv[2], &readable) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[3], &writable) != TCL_OK) { + return TCL_ERROR; + } + + + /* + * Validate the property name and install the implementations... if asked + * to do so. + */ + + return InstallStdPropertyImpls(useInstance, interp, propName, readable, + writable); } /* diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 07408f8..c31c461 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -169,16 +169,15 @@ typedef struct { typedef LIST_STATIC(Tcl_Obj *) VariableNameList; typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; +typedef LIST_STATIC(Tcl_Obj *) PropertyList; /* * 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. */ + PropertyList readable; /* The readable properties slot. */ + PropertyList 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 @@ -498,7 +497,8 @@ MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineSelfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjSelfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefinePrivateObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclOOInstallStdPropertyImpls; +MODULE_SCOPE Tcl_ObjCmdProc TclOOInstallStdPropertyImplsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOPropertyDefinitionCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOUnknownDefinition; MODULE_SCOPE Tcl_ObjCmdProc TclOOCopyObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOONextObjCmd; @@ -611,6 +611,10 @@ MODULE_SCOPE void TclOOSortPropList(Tcl_Obj *listPtr); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); +MODULE_SCOPE void TclOORegisterProperty(Class *clsPtr, + Tcl_Obj *propName, int mayRead, int mayWrite); +MODULE_SCOPE void TclOORegisterInstanceProperty(Object *oPtr, + Tcl_Obj *propName, int mayRead, int mayWrite); /* * Include all the private API, generated from tclOO.decls. diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 7538d48..98fa20e 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -258,99 +258,13 @@ static const char *tclOOSetupScript = "\t\tsuperclass class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" -"\t::namespace eval configuresupport {\n" -"\t\tnamespace path ::tcl\n" -"\t\tproc PropertyImpl {stdInstaller 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\tset realprop [string cat \"-\" $prop]\n" -"\t\t\t\tunset -nocomplain getter setter\n" -"\t\t\t\tset kind readwrite\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 [prefix match -error [list -level 1 -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 -level 1 \\\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 -level 1 \\\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 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 -level 1 \\\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 [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" -"\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\tset addReader [expr {$kind ne \"writable\" && ![info exist getter]}]\n" -"\t\t\t\tset addWriter [expr {$kind ne \"readable\" && ![info exist setter]}]\n" -"\t\t\t\ttry {\n" -"\t\t\t\t\tuplevel 1 [list $stdInstaller $prop $addReader $addWriter]\n" -"\t\t\t\t} on error {msg opt} {\n" -"\t\t\t\t\treturn -code error -level 1 \\\n" -"\t\t\t\t\t\t\t-errorcode [dict get $opt -errorcode] $msg\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 $writeslot -remove $realprop]\n" -"\t\t\t\t\t}\n" -"\t\t\t\t\twritable {\n" -"\t\t\t\t\t\tuplevel 1 [list $readslot -remove $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\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}\n" -"\t\t\t\t}\n" -"\t\t\t\tif {[info exist getter]} {\n" -"\t\t\t\t\tuplevel 1 [list method $reader -unexport {} $getter]\n" -"\t\t\t\t}\n" -"\t\t\t\tif {[info exist setter]} {\n" -"\t\t\t\t\tuplevel 1 [list method $writer -unexport {value} $setter]\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t}\n" -"\t\tnamespace eval configurableclass {\n" -"\t\t\t::interp alias \\\n" -"\t\t\t\t\t{} ::oo::configuresupport::configurableclass::property {} \\\n" -"\t\t\t\t\t::oo::configuresupport::PropertyImpl \\\n" -"\t\t\t\t\t::oo::configuresupport::StdClassProperties \\\n" -"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" -"\t\t\t\t\t::oo::configuresupport::writableproperties\n" +"\tnamespace eval configuresupport {\n" +"\t\t::namespace eval configurableclass {\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" -"\t\tnamespace eval configurableobject {\n" -"\t\t\t::interp alias \\\n" -"\t\t\t\t\t{} ::oo::configuresupport::configurableobject::property {} \\\n" -"\t\t\t\t\t::oo::configuresupport::PropertyImpl \\\n" -"\t\t\t\t\t::oo::configuresupport::StdObjectProperties \\\n" -"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" -"\t\t\t\t\t::oo::configuresupport::objwritableproperties\n" +"\t\t::namespace eval configurableobject {\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" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 22f0e91..fc0927c 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -470,134 +470,20 @@ # * objreadableproperties # * objwritableproperties # - # Those are all slot implementations that provide access to the C layer + # 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). + # # ---------------------------------------------------------------------- - ::namespace eval configuresupport { - namespace path ::tcl - - # ------------------------------------------------------------------ - # - # oo::configuresupport::PropertyImpl -- - # - # The implementation of the [property] configuration command. - # This assumes there is a context scope of [oo::define] or - # [oo::objdefine] as the stack frame that is up one level. - # - # TODO: - # Convert to C code. - # - # Arguments: - # stdInstaller - # How to install a property implementation of the right type. - # Must be evaluated in the definition scope. - # readslot - # Slot of readable properties. - # Must be evaluated in the definition scope. - # writeslot - # Slot of writable properties. - # Must be evaluated in the definition scope. - # args - # Arguments supplied by user. See user documentation. - # - # Results: - # None - # - # Errors: - # TCL WRONGARGS - # if an argument is missing. - # TCL LOOKUP INDEX - # if an option or property kind can't be parsed. - # TCL OO PROPERTY_FORMAT - # if an property name is illegal. - # - # Side effects: - # Adjusts properties. Declares non-exported methods with special - # names. - # - # ------------------------------------------------------------------ - - proc PropertyImpl {stdInstaller readslot writeslot args} { - for {set i 0} {$i < [llength $args]} {incr i} { - # Parse the property name - set prop [lindex $args $i] - set realprop [string cat "-" $prop] - unset -nocomplain getter setter - set kind readwrite - - # Parse the extra options for the property - while {[set next [lindex $args [expr {$i + 1}]] - string match "-*" $next]} { - set arg [lindex $args [incr i 2]] - switch [prefix match -error [list -level 1 -errorcode \ - [list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] { - -get { - if {$i >= [llength $args]} { - return -code error -level 1 \ - -errorcode {TCL WRONGARGS} \ - "missing body to go with -get option" - } - set getter $arg - } - -set { - if {$i >= [llength $args]} { - return -code error -level 1 \ - -errorcode {TCL WRONGARGS} \ - "missing body to go with -set option" - } - set setter $arg - } - -kind { - if {$i >= [llength $args]} { - return -code error -level 1 \ - -errorcode {TCL WRONGARGS} \ - "missing kind value to go with -kind option" - } - set kind [prefix match -message "kind" -error [list \ - -level 2 \ - -errorcode [list TCL LOOKUP INDEX kind $arg]] { - readable readwrite writable - } $arg] - } - } - } - - # Install the property - set reader - set writer - set addReader [expr {$kind ne "writable" && ![info exist getter]}] - set addWriter [expr {$kind ne "readable" && ![info exist setter]}] - try { - uplevel 1 [list $stdInstaller $prop $addReader $addWriter] - } on error {msg opt} { - return -code error -level 1 \ - -errorcode [dict get $opt -errorcode] $msg - } - switch $kind { - readable { - uplevel 1 [list $readslot -append $realprop] - uplevel 1 [list $writeslot -remove $realprop] - } - writable { - uplevel 1 [list $readslot -remove $realprop] - uplevel 1 [list $writeslot -append $realprop] - } - readwrite { - uplevel 1 [list $readslot -append $realprop] - uplevel 1 [list $writeslot -append $realprop] - } - } - if {[info exist getter]} { - uplevel 1 [list method $reader -unexport {} $getter] - } - if {[info exist setter]} { - uplevel 1 [list method $writer -unexport {value} $setter] - } - } - } - + namespace eval configuresupport { # ------------------------------------------------------------------ # # oo::configuresupport::configurableclass, @@ -605,29 +491,19 @@ # # 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 configurableclass { - ::interp alias \ - {} ::oo::configuresupport::configurableclass::property {} \ - ::oo::configuresupport::PropertyImpl \ - ::oo::configuresupport::StdClassProperties \ - ::oo::configuresupport::readableproperties \ - ::oo::configuresupport::writableproperties + ::namespace eval configurableclass { # Plural alias just in case; deliberately NOT documented! ::proc properties args {::tailcall property {*}$args} ::namespace path ::oo::define ::namespace export property } - namespace eval configurableobject { - ::interp alias \ - {} ::oo::configuresupport::configurableobject::property {} \ - ::oo::configuresupport::PropertyImpl \ - ::oo::configuresupport::StdObjectProperties \ - ::oo::configuresupport::objreadableproperties \ - ::oo::configuresupport::objwritableproperties + ::namespace eval configurableobject { # Plural alias just in case; deliberately NOT documented! ::proc properties args {::tailcall property {*}$args} ::namespace path ::oo::objdefine -- cgit v0.12