From 76c3874ad8500c1db1360a8a80ae1f8040f32448 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 28 Dec 2019 21:55:56 +0000 Subject: Starting to do the testing. --- generic/tclOOScript.h | 57 +++++++----- tests/oo.test | 248 +++++++++++++++++++++++++++++++++++++++++++++++++- tools/tclOOScript.tcl | 131 ++++++++++++++++++++------ 3 files changed, 379 insertions(+), 57 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index c8a79a9..b9223ee 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -249,7 +249,7 @@ static const char *tclOOSetupScript = "\t\tunexport create createWithNamespace new\n" "\t}\n" "\tnamespace eval configuresupport {\n" -"\t\tproc property {readslot writeslot args} {\n" +"\t\tproc PropertyImpl {readslot writeslot args} {\n" "\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n" "\t\t\t\tset prop [lindex $args $i]\n" "\t\t\t\tif {[string match \"-*\" $prop]} {\n" @@ -260,7 +260,8 @@ static const char *tclOOSetupScript = "\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n" "\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n" "\t\t\t\tset kind readwrite\n" -"\t\t\t\twhile {[string match \"-*\" [set next [lindex $args [expr {$i + 1}]]]]} {\n" +"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n" +"\t\t\t\t\t\tstring match \"-*\" $next]} {\n" "\t\t\t\t\tset arg [lindex $args [incr i 2]]\n" "\t\t\t\t\tswitch [::tcl::prefix match {-get -kind -set} $next] {\n" "\t\t\t\t\t\t-get {\n" @@ -290,50 +291,47 @@ static const char *tclOOSetupScript = "\t\t\t\t}\n" "\t\t\t\tswitch $kind {\n" "\t\t\t\t\treadable {\n" -"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list method {} $getter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {} $getter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\twritable {\n" -"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list method {value} $setter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t\treadwrite {\n" -"\t\t\t\t\t\tuplevel 1 [list $readslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list $writeslot -append $realprop]\n" -"\t\t\t\t\t\tuplevel 1 [list method {} $getter]\n" -"\t\t\t\t\t\tuplevel 1 [list method {value} $setter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$readslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\t$writeslot -append $realprop]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {} $getter]\n" +"\t\t\t\t\t\tuplevel 1 [list \\\n" +"\t\t\t\t\t\t\t\tmethod {value} $setter]\n" "\t\t\t\t\t}\n" "\t\t\t\t}\n" "\t\t\t}\n" "\t\t}\n" "\t\tnamespace eval configurableclass {\n" "\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::property \\\n" +"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::readableproperties \\\n" -"\t\t\t\t\t::oo::configuresupport::writableproperties \\\n" -"\t\t\t\t\t{*}$args\n" +"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n" "\t\t\t}\n" "\t\t\tnamespace path ::oo::define\n" "\t\t}\n" "\t\tnamespace eval configurableobject {\n" "\t\t\tproc property args {\n" -"\t\t\t\ttailcall ::oo::configuresupport::property \\\n" +"\t\t\t\ttailcall ::oo::configuresupport::PropertyImpl \\\n" "\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n" -"\t\t\t\t\t::oo::configuresupport::objwritableproperties \\\n" -"\t\t\t\t\t{*}$args\n" +"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n" "\t\t\t}\n" "\t\t\tnamespace path ::oo::objdefine\n" "\t\t}\n" "\t}\n" -"\tclass create configurable {\n" -"\t\tsuperclass class\n" -"\t\tconstructor {{definitionScript \"\"}} {\n" -"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" -"\t\t\tnext $definitionScript\n" -"\t\t}\n" -"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" -"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" -"\t}\n" "\tclass create configuresupport::configurable {\n" "\t\tprivate method Configure:Match {prop kind} {\n" "\t\t\tset props [info object property [self] -all $kind]\n" @@ -362,6 +360,15 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t}\n" "\t}\n" +"\tclass create configurable {\n" +"\t\tsuperclass class\n" +"\t\tconstructor {{definitionScript \"\"}} {\n" +"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n" +"\t\t\tnext $definitionScript\n" +"\t\t}\n" +"\t\tdefinitionnamespace -class configuresupport::configurableclass\n" +"\t\tdefinitionnamespace -instance configuresupport::configurableobject\n" +"\t}\n" "}\n" /* !END!: Do not edit above this line. */ ; diff --git a/tests/oo.test b/tests/oo.test index 235a90d..16045dd 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -342,7 +342,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as @@ -2424,7 +2424,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, property, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -2643,7 +2643,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, property, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { @@ -4186,7 +4186,7 @@ test oo-34.1 {TIP 380: slots - presence} -setup { } -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot} test oo-34.2 {TIP 380: slots - presence} { lsort [info class instances oo::Slot] -} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} +} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} proc getMethods obj { list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] @@ -5448,6 +5448,246 @@ test oo-43.13 {TIP 524: definition namespace control: user-level introspection} parent destroy namespace delete foodef } -result {{} {} ::foodef {} {}} + +test oo-44.1 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class property c] [info class property c -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test oo-44.2 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a a + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class property c -all] [info class property c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}} +test oo-44.3 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class property c] [info class property c -writable] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class property c] [info class property c -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test oo-44.4 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a a + lappend result [info class property c -all] [info class property c -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class property c -all] [info class property c -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}} +test oo-44.5 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b c + oo::define d ::oo::configuresupport::readableproperties -set x y z + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set f e d + oo::define d ::oo::configuresupport::readableproperties -set r p q + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a a h + oo::define d ::oo::configuresupport::readableproperties -set g h g + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] + oo::define d ::oo::configuresupport::readableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}} +test oo-44.6 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b c + oo::define d ::oo::configuresupport::writableproperties -set x y z + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set f e d + oo::define d ::oo::configuresupport::writableproperties -set r p q + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a a h + oo::define d ::oo::configuresupport::writableproperties -set g h g + lappend result [info class property d -all] [info class property d -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] + oo::define d ::oo::configuresupport::writableproperties -set + lappend result [info class property d -all] [info class property d -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}} +test oo-44.7 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set + lappend result [info object property o] [info object property o -writable] +} -cleanup { + parent destroy +} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}} +test oo-44.8 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + c create o + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h + lappend result [info object property o] [info object property o -writable] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set + lappend result [info object property o] [info object property o -writable] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}} +test oo-44.9 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object property o -all] [info object property o -writable -all] + oo::define c ::oo::configuresupport::readableproperties -set a b + oo::define d ::oo::configuresupport::readableproperties -set c d + oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f + lappend result [info object property o -all] [info object property o -writable -all] + oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e + lappend result [info object property o -all] [info object property o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {a b c d e f} {} {a b c d e f} {}} +test oo-44.10 {TIP 558: properties: core support} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::class create c {superclass parent} + oo::class create d {superclass c} + d create o + lappend result [info object property o -all] [info object property o -writable -all] + oo::define c ::oo::configuresupport::writableproperties -set a b + oo::define d ::oo::configuresupport::writableproperties -set c d + oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f + lappend result [info object property o -all] [info object property o -writable -all] + oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e + lappend result [info object property o -all] [info object property o -writable -all] +} -cleanup { + parent destroy +} -result {{} {} {} {a b c d e f} {} {a b c d e f}} + +test oo-45.1 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -body { + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + variable x y + method report {} { + lappend ::result "x=$x, y=$y" + } + } + set pt [Point new -x 3] + $pt report + $pt configure -y 4 + $pt report + lappend result [$pt configure -x],[$pt configure -y] [$pt configure] +} -cleanup { + parent destroy +} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}} +test oo-45.2 {TIP 558: properties: configurable class system} -setup { + oo::class create parent + unset -nocomplain result + set result {} +} -constraints knownBug -body { # FIXME # FIXME # FIXME # FIXME + oo::configurable create Point { + superclass parent + property x y + constructor args { + my configure -x 0 -y 0 {*}$args + } + } + set pt [Point new -x 3 -y 4] + oo::objdefine $pt property z + $pt configure -z 5 + lappend result [$pt configure -x],[$pt configure -y],[$pt configure -z] \ + [$pt configure] +} -cleanup { + parent destroy +} -result {3,4,5 {-x 3 -y 4 -z 5}} cleanupTests return diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 8cc9627..5ae357a 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -450,15 +450,32 @@ # ---------------------------------------------------------------------- # - # oo::configurable -- + # oo::configuresupport -- + # + # Namespace that holds all the implementation details of TIP #558. + # Also includes the commands: # - # A metaclass that is used to make classes that can be configured. Also - # its supporting classes and namespaces. + # * readableproperties + # * writableproperties + # * objreadableproperties + # * objwritableproperties + # + # Those are all slot implementations that provide access to the C layer + # of property support (i.e., very fast cached lookup of property names). # # ---------------------------------------------------------------------- namespace eval configuresupport { - proc property {readslot writeslot args} { + + # ------------------------------------------------------------------ + # + # oo::configuresupport -- + # + # A metaclass that is used to make classes that can be configured. + # + # ------------------------------------------------------------------ + + proc PropertyImpl {readslot writeslot args} { for {set i 0} {$i < [llength $args]} {incr i} { # Parse the property name set prop [lindex $args $i] @@ -472,7 +489,8 @@ set kind readwrite # Parse the extra options - while {[string match "-*" [set next [lindex $args [expr {$i + 1}]]]]} { + while {[set next [lindex $args [expr {$i + 1}]] + string match "-*" $next]} { set arg [lindex $args [incr i 2]] switch [::tcl::prefix match {-get -kind -set} $next] { -get { @@ -504,80 +522,137 @@ # Install the option switch $kind { readable { - uplevel 1 [list $readslot -append $realprop] - uplevel 1 [list method {} $getter] + uplevel 1 [list \ + $readslot -append $realprop] + uplevel 1 [list \ + method {} $getter] } writable { - uplevel 1 [list $writeslot -append $realprop] - uplevel 1 [list method {value} $setter] + uplevel 1 [list \ + $writeslot -append $realprop] + uplevel 1 [list \ + method {value} $setter] } readwrite { - uplevel 1 [list $readslot -append $realprop] - uplevel 1 [list $writeslot -append $realprop] - uplevel 1 [list method {} $getter] - uplevel 1 [list method {value} $setter] + uplevel 1 [list \ + $readslot -append $realprop] + uplevel 1 [list \ + $writeslot -append $realprop] + uplevel 1 [list \ + method {} $getter] + uplevel 1 [list \ + method {value} $setter] } } } } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::configurableclass, + # oo::configuresupport::configurableobject -- + # + # Namespaces used as implementation vectors for oo::define and + # oo::objdefine when the class/instance is configurable. + # + # ------------------------------------------------------------------ + namespace eval configurableclass { proc property args { - tailcall ::oo::configuresupport::property \ + tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::readableproperties \ - ::oo::configuresupport::writableproperties \ - {*}$args + ::oo::configuresupport::writableproperties {*}$args } namespace path ::oo::define } + namespace eval configurableobject { proc property args { - tailcall ::oo::configuresupport::property \ + tailcall ::oo::configuresupport::PropertyImpl \ ::oo::configuresupport::objreadableproperties \ - ::oo::configuresupport::objwritableproperties \ - {*}$args + ::oo::configuresupport::objwritableproperties {*}$args } namespace path ::oo::objdefine } } - class create configurable { - superclass class - constructor {{definitionScript ""}} { - next {mixin ::oo::configuresupport::configurable} - next $definitionScript - } - definitionnamespace -class configuresupport::configurableclass - definitionnamespace -instance configuresupport::configurableobject - } + # ---------------------------------------------------------------------- + # + # oo::configuresupport::configurable -- + # + # The class that contains the implementation of the actual 'configure' + # method. + # + # ---------------------------------------------------------------------- class create configuresupport::configurable { + # + # Configure:Match -- + # Support method for doing the matching of property names + # (including unambiguous prefixes) to the actual real property + # name. + # private method Configure:Match {prop kind} { set props [info object property [self] -all $kind] ::tcl::prefix match -message "property" $props $prop } + + # + # configure -- + # Method for providing client access to the property mechanism. + # Has a user-facing API similar to that of [chan configure]. + # method configure args { if {[llength $args] == 0} { + # Read all properties set result {} foreach prop [info object property [self] -all -readable] { dict set result $prop [my ] } return $result } elseif {[llength $args] == 1} { + # Read a single property set prop [my Configure:Match [lindex $args 0] -readable] return [my ] } elseif {[llength $args] % 2 == 0} { + # Set properties, one or several foreach {prop value} $args { set prop [my Configure:Match $prop -writable] my $value } return } else { + # Invalid call return -code error -errorcode {TCL WRONGARGS} \ [format "wrong # args: should be \"%s\"" \ "[self] configure ?-option value ...?"] } } } + + # ---------------------------------------------------------------------- + # + # oo::configurable -- + # + # A metaclass that is used to make classes that can be configured. All + # the metaclass itself does is arrange for the class created to have a + # 'configure' method and for oo::define and oo::objdefine (on the class + # and its instances) to have a property definition for setting things up + # for 'configure'. + # + # ---------------------------------------------------------------------- + + class create configurable { + superclass class + + constructor {{definitionScript ""}} { + next {mixin ::oo::configuresupport::configurable} + next $definitionScript + } + + definitionnamespace -class configuresupport::configurableclass + definitionnamespace -instance configuresupport::configurableobject + } } # Local Variables: -- cgit v0.12