From a7a226fc4988c02841c106b4f1a8fd7af2c5a0c2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 29 Dec 2019 13:23:47 +0000 Subject: Property definitions now work on instances. --- generic/tclOOCall.c | 9 +-- generic/tclOOScript.h | 81 ++++++++++++++---------- tests/oo.test | 2 +- tools/tclOOScript.tcl | 167 ++++++++++++++++++++++++++++++++------------------ 4 files changed, 164 insertions(+), 95 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index f647fb7..6b88b3d 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -59,6 +59,7 @@ typedef struct { #define BUILDING_MIXINS 0x400000 #define TRAVERSED_MIXIN 0x800000 #define OBJECT_MIXIN 0x1000000 +#define DEFINE_FOR_CLASS 0x2000000 #define MIXIN_CONSISTENT(flags) \ (((flags) & OBJECT_MIXIN) || \ !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) @@ -1896,7 +1897,7 @@ TclOOGetDefineContextNamespace( DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; DefineEntry *entryPtr; Tcl_Namespace *nsPtr = NULL; - int i; + int i, flags = (forClass ? DEFINE_FOR_CLASS : 0); define.list = staticSpace; define.num = 0; @@ -1907,8 +1908,8 @@ TclOOGetDefineContextNamespace( * class mixins right. */ - AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS); - AddSimpleDefineNamespaces(oPtr, &define, forClass); + AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS); + AddSimpleDefineNamespaces(oPtr, &define, flags); /* * Go through the list until we find a namespace whose name we can @@ -1992,7 +1993,7 @@ AddSimpleClassDefineNamespaces( flags | TRAVERSED_MIXIN); } - if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) { + if (flags & DEFINE_FOR_CLASS) { AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, definePtr, flags); } else { diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index b9223ee..8d8dd2a 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -29,7 +29,7 @@ static const char *tclOOSetupScript = "::namespace eval ::oo {\n" "\t::namespace path {}\n" "\tnamespace eval Helpers {\n" -"\t\t::namespace path {}\n" +"\t\tnamespace path {}\n" "\t\tproc callback {method args} {\n" "\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" "\t\t}\n" @@ -248,7 +248,7 @@ static const char *tclOOSetupScript = "\t\tsuperclass class\n" "\t\tunexport create createWithNamespace new\n" "\t}\n" -"\tnamespace eval configuresupport {\n" +"\t::namespace eval configuresupport {\n" "\t\tproc PropertyImpl {readslot writeslot args} {\n" "\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n" "\t\t\t\tset prop [lindex $args $i]\n" @@ -316,48 +316,66 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t}\n" "\t\tnamespace eval configurableclass {\n" -"\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" +"\t\t\t::proc property args {\n" +"\t\t\t\t::tailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n" "\t\t\t}\n" -"\t\t\tnamespace path ::oo::define\n" +"\t\t\t::namespace path ::oo::define\n" +"\t\t\t::namespace export property\n" "\t\t}\n" "\t\tnamespace eval configurableobject {\n" -"\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" +"\t\t\t::proc property args {\n" +"\t\t\t\t::tailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" "\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n" "\t\t\t}\n" -"\t\t\tnamespace path ::oo::objdefine\n" +"\t\t\t::namespace path ::oo::objdefine\n" +"\t\t\t::namespace export property\n" "\t\t}\n" -"\t}\n" -"\tclass create configuresupport::configurable {\n" -"\t\tprivate method Configure:Match {prop kind} {\n" -"\t\t\tset props [info object property [self] -all $kind]\n" -"\t\t\t::tcl::prefix match -message \"property\" $props $prop\n" +"\t\tproc ReadAll {object my} {\n" +"\t\t\tset result {}\n" +"\t\t\tforeach prop [info object property $object -all -readable] {\n" +"\t\t\t\tdict set result $prop [$my ]\n" +"\t\t\t}\n" +"\t\t\treturn $result\n" "\t\t}\n" -"\t\tmethod configure args {\n" -"\t\t\tif {[llength $args] == 0} {\n" -"\t\t\t\tset result {}\n" -"\t\t\t\tforeach prop [info object property [self] -all -readable] {\n" -"\t\t\t\t\tdict set result $prop [my ]\n" +"\t\tproc Match {object propertyName kind} {\n" +"\t\t\tset props [info object property $object -all $kind]\n" +"\t\t\t::tcl::prefix match -message \"property\" $props $propertyName\n" +"\t\t}\n" +"\t\tproc ReadOne {object my propertyName} {\n" +"\t\t\tset prop [Match $object $propertyName -readable]\n" +"\t\t\treturn [$my ]\n" +"\t\t}\n" +"\t\tproc WriteMany {object my setterMap} {\n" +"\t\t\tforeach {prop value} $setterMap {\n" +"\t\t\t\tset prop [Match $object $prop -writable]\n" +"\t\t\t\t$my $value\n" +"\t\t\t}\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\t::oo::class create configurable {\n" +"\t\t\tprivate variable my\n" +"\t\t\tmethod configure args {\n" +"\t\t\t\t::if {![::info exists my]} {\n" +"\t\t\t\t\t::set my [::namespace which my]\n" "\t\t\t\t}\n" -"\t\t\t\treturn $result\n" -"\t\t\t} elseif {[llength $args] == 1} {\n" -"\t\t\t\tset prop [my Configure:Match [lindex $args 0] -readable]\n" -"\t\t\t\treturn [my ]\n" -"\t\t\t} elseif {[llength $args] % 2 == 0} {\n" -"\t\t\t\tforeach {prop value} $args {\n" -"\t\t\t\t\tset prop [my Configure:Match $prop -writable]\n" -"\t\t\t\t\tmy $value\n" +"\t\t\t\t::if {[::llength $args] == 0} {\n" +"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n" +"\t\t\t\t} elseif {[::llength $args] == 1} {\n" +"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n" +"\t\t\t\t\t\t[::lindex $args 0]\n" +"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n" +"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n" +"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n" +"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n" "\t\t\t\t}\n" -"\t\t\t\treturn\n" -"\t\t\t} else {\n" -"\t\t\t\treturn -code error -errorcode {TCL WRONGARGS} \\\n" -"\t\t\t\t\t[format \"wrong # args: should be \\\"%s\\\"\" \\\n" -"\t\t\t\t\t\t \"[self] configure \?-option value ...\?\"]\n" "\t\t\t}\n" +"\t\t\tdefinitionnamespace -instance configurableobject\n" +"\t\t\tdefinitionnamespace -class configurableclass\n" "\t\t}\n" "\t}\n" "\tclass create configurable {\n" @@ -367,7 +385,6 @@ static const char *tclOOSetupScript = "\t\t\tnext $definitionScript\n" "\t\t}\n" "\t\tdefinitionnamespace -class configuresupport::configurableclass\n" -"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" "\t}\n" "}\n" /* !END!: Do not edit above this line. */ diff --git a/tests/oo.test b/tests/oo.test index 16045dd..32a0cf1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5672,7 +5672,7 @@ test oo-45.2 {TIP 558: properties: configurable class system} -setup { oo::class create parent unset -nocomplain result set result {} -} -constraints knownBug -body { # FIXME # FIXME # FIXME # FIXME +} -body { oo::configurable create Point { superclass parent property x y diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 5ae357a..b441765 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -18,7 +18,7 @@ # Commands that are made available to objects by default. # namespace eval Helpers { - ::namespace path {} + namespace path {} # ------------------------------------------------------------------ # @@ -465,7 +465,7 @@ # # ---------------------------------------------------------------------- - namespace eval configuresupport { + ::namespace eval configuresupport { # ------------------------------------------------------------------ # @@ -558,75 +558,127 @@ # ------------------------------------------------------------------ namespace eval configurableclass { - proc property args { - tailcall ::oo::configuresupport::PropertyImpl \ + ::proc property args { + ::tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::readableproperties \ ::oo::configuresupport::writableproperties {*}$args } - namespace path ::oo::define + ::namespace path ::oo::define + ::namespace export property } namespace eval configurableobject { - proc property args { - tailcall ::oo::configuresupport::PropertyImpl \ + ::proc property args { + ::tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::objreadableproperties \ ::oo::configuresupport::objwritableproperties {*}$args } - namespace path ::oo::objdefine + ::namespace path ::oo::objdefine + ::namespace export property } - } - # ---------------------------------------------------------------------- - # - # oo::configuresupport::configurable -- - # - # The class that contains the implementation of the actual 'configure' - # method. - # - # ---------------------------------------------------------------------- + # ------------------------------------------------------------------ + # + # oo::configuresupport::ReadAll -- + # + # The implementation of [$o configure] with no extra arguments. + # + # ------------------------------------------------------------------ + + proc ReadAll {object my} { + set result {} + foreach prop [info object property $object -all -readable] { + dict set result $prop [$my ] + } + return $result + } - class create configuresupport::configurable { + # ------------------------------------------------------------------ # - # Configure:Match -- - # Support method for doing the matching of property names - # (including unambiguous prefixes) to the actual real property - # name. - # - private method Configure:Match {prop kind} { - set props [info object property [self] -all $kind] - ::tcl::prefix match -message "property" $props $prop + # oo::configuresupport::Match -- + # + # How to convert an imprecise property name into a full one. + # + # ------------------------------------------------------------------ + + proc Match {object propertyName kind} { + set props [info object property $object -all $kind] + ::tcl::prefix match -message "property" $props $propertyName } + # ------------------------------------------------------------------ # - # configure -- - # Method for providing client access to the property mechanism. - # Has a user-facing API similar to that of [chan configure]. - # - method configure args { - if {[llength $args] == 0} { - # Read all properties - set result {} - foreach prop [info object property [self] -all -readable] { - dict set result $prop [my ] + # oo::configuresupport::ReadOne -- + # + # The implementation of [$o configure -prop] with that single + # extra argument. + # + # ------------------------------------------------------------------ + + proc ReadOne {object my propertyName} { + set prop [Match $object $propertyName -readable] + return [$my ] + } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::WriteMany -- + # + # The implementation of [$o configure -prop val ?-prop val...?]. + # + # ------------------------------------------------------------------ + + proc WriteMany {object my setterMap} { + foreach {prop value} $setterMap { + set prop [Match $object $prop -writable] + $my $value + } + return + } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurable -- + # + # The class that contains the implementation of the actual + # 'configure' method (mixed into actually configurable classes). + # Great care needs to be taken in these methods as they are + # potentially used in classes where the current namespace is set + # up very strangely. + # + # ------------------------------------------------------------------ + + ::oo::class create configurable { + private variable my + # + # configure -- + # Method for providing client access to the property mechanism. + # Has a user-facing API similar to that of [chan configure]. + # + method configure args { + ::if {![::info exists my]} { + ::set my [::namespace which my] } - return $result - } elseif {[llength $args] == 1} { - # Read a single property - set prop [my Configure:Match [lindex $args 0] -readable] - return [my ] - } elseif {[llength $args] % 2 == 0} { - # Set properties, one or several - foreach {prop value} $args { - set prop [my Configure:Match $prop -writable] - my $value + ::if {[::llength $args] == 0} { + # Read all properties + ::oo::configuresupport::ReadAll [self] $my + } elseif {[::llength $args] == 1} { + # Read a single property + ::oo::configuresupport::ReadOne [self] $my \ + [::lindex $args 0] + } elseif {[::llength $args] % 2 == 0} { + # Set properties, one or several + ::oo::configuresupport::WriteMany [self] $my $args + } else { + # Invalid call + ::return -code error -errorcode {TCL WRONGARGS} \ + [::format {wrong # args: should be "%s"} \ + "[self] configure ?-option value ...?"] } - return - } else { - # Invalid call - return -code error -errorcode {TCL WRONGARGS} \ - [format "wrong # args: should be \"%s\"" \ - "[self] configure ?-option value ...?"] } + + definitionnamespace -instance configurableobject + definitionnamespace -class configurableclass } } @@ -634,11 +686,11 @@ # # oo::configurable -- # - # A metaclass that is used to make classes that can be configured. All - # the metaclass itself does is arrange for the class created to have a - # 'configure' method and for oo::define and oo::objdefine (on the class - # and its instances) to have a property definition for setting things up - # for 'configure'. + # A metaclass that is used to make classes that can be configured in + # their creation phase (and later too). All the metaclass itself does is + # arrange for the class created to have a 'configure' method and for + # oo::define and oo::objdefine (on the class and its instances) to have + # a property definition for setting things up for 'configure'. # # ---------------------------------------------------------------------- @@ -651,7 +703,6 @@ } definitionnamespace -class configuresupport::configurableclass - definitionnamespace -instance configuresupport::configurableobject } } -- cgit v0.12