diff options
Diffstat (limited to 'tools/tclOOScript.tcl')
| -rw-r--r-- | tools/tclOOScript.tcl | 266 |
1 files changed, 265 insertions, 1 deletions
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 5e0145f..4dbc48c 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 {} # ------------------------------------------------------------------ # @@ -447,6 +447,270 @@ superclass class unexport create createWithNamespace new } + + # ---------------------------------------------------------------------- + # + # oo::configuresupport -- + # + # Namespace that holds all the implementation details of TIP #558. + # Also includes the commands: + # + # * 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 { + namespace path ::tcl + + # ------------------------------------------------------------------ + # + # 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] + if {[string match "-*" $prop]} { + return -code error -level 2 \ + -errorcode {TCLOO PROPERTY_FORMAT} \ + "bad property name \"$prop\"; must not begin with -" + } + set realprop [string cat "-" $prop] + set getter [format {::set [my varname %s]} $prop] + set setter [format {::set [my varname %s] $value} $prop] + set kind readwrite + + # Parse the extra options + while {[set next [lindex $args [expr {$i + 1}]] + string match "-*" $next]} { + set arg [lindex $args [incr i 2]] + switch [prefix match -error [list -level 2 -errorcode \ + [list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] { + -get { + if {$i >= [llength $args]} { + return -code error -level 2 \ + -errorcode {TCL WRONGARGS} \ + "missing body to go with -get option" + } + set getter $arg + } + -set { + if {$i >= [llength $args]} { + return -code error -level 2 \ + -errorcode {TCL WRONGARGS} \ + "missing body to go with -set option" + } + set setter $arg + } + -kind { + if {$i >= [llength $args]} { + return -code error -level 2\ + -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 option + switch $kind { + readable { + uplevel 2 [list \ + $readslot -append $realprop] + uplevel 2 [list \ + $writeslot -remove $realprop] + uplevel 2 [list \ + method <ReadProp$realprop> {} $getter] + } + writable { + uplevel 2 [list \ + $readslot -remove $realprop] + uplevel 2 [list \ + $writeslot -append $realprop] + uplevel 2 [list \ + method <WriteProp$realprop> {value} $setter] + } + readwrite { + uplevel 2 [list \ + $readslot -append $realprop] + uplevel 2 [list \ + $writeslot -append $realprop] + uplevel 2 [list \ + method <ReadProp$realprop> {} $getter] + uplevel 2 [list \ + method <WriteProp$realprop> {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 { + ::oo::configuresupport::PropertyImpl \ + ::oo::configuresupport::readableproperties \ + ::oo::configuresupport::writableproperties {*}$args + } + ::namespace path ::oo::define + ::namespace export property + } + + namespace eval configurableobject { + ::proc property args { + ::oo::configuresupport::PropertyImpl \ + ::oo::configuresupport::objreadableproperties \ + ::oo::configuresupport::objwritableproperties {*}$args + } + ::namespace path ::oo::objdefine + ::namespace export property + } + + # ------------------------------------------------------------------ + # + # 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 <ReadProp$prop>] + } + return $result + } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::ReadOne -- + # + # The implementation of [$o configure -prop] with that single + # extra argument. + # + # ------------------------------------------------------------------ + + proc ReadOne {object my propertyName} { + set props [info object property $object -all -readable] + set prop [prefix match -message "property" -error [list\ + -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $propertyName]] \ + $props $propertyName] + return [$my <ReadProp$prop>] + } + + # ------------------------------------------------------------------ + # + # oo::configuresupport::WriteMany -- + # + # The implementation of [$o configure -prop val ?-prop val...?]. + # + # ------------------------------------------------------------------ + + proc WriteMany {object my setterMap} { + set props [info object property $object -all -writable] + foreach {prop value} $setterMap { + set prop [prefix match -message "property" -error [list\ + -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $prop]] \ + $props $prop] + $my <WriteProp$prop> $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] + } + ::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 ...?"] + } + } + + definitionnamespace -instance configurableobject + definitionnamespace -class 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 { + superclass class + + constructor {{definitionScript ""}} { + next {mixin ::oo::configuresupport::configurable} + next $definitionScript + } + + definitionnamespace -class configuresupport::configurableclass + } } # Local Variables: |