diff options
Diffstat (limited to 'tools/tclOOScript.tcl')
| -rw-r--r-- | tools/tclOOScript.tcl | 273 |
1 files changed, 16 insertions, 257 deletions
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 0cbe5b7..fc0927c 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -470,112 +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 -- - # - # 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 {TCL OO PROPERTY_FORMAT} \ - "bad property name \"$prop\": must not begin with -" - } - if {$prop ne [list $prop]} { - return -code error -level 2 \ - -errorcode {TCL OO PROPERTY_FORMAT} \ - "bad property name \"$prop\": must be a simple word" - } - if {[string first "::" $prop] != -1} { - return -code error -level 2 \ - -errorcode {TCL OO PROPERTY_FORMAT} \ - "bad property name \"$prop\": must not contain namespace separators" - } - if {[string match {*[()]*} $prop]} { - return -code error -level 2 \ - -errorcode {TCL OO PROPERTY_FORMAT} \ - "bad property name \"$prop\": must not contain parentheses" - } - 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 - set reader <ReadProp$realprop> - set writer <WriteProp$realprop> - switch $kind { - readable { - uplevel 2 [list $readslot -append $realprop] - uplevel 2 [list $writeslot -remove $realprop] - uplevel 2 [list method $reader -unexport {} $getter] - } - writable { - uplevel 2 [list $readslot -remove $realprop] - uplevel 2 [list $writeslot -append $realprop] - uplevel 2 [list method $writer -unexport {value} $setter] - } - readwrite { - uplevel 2 [list $readslot -append $realprop] - uplevel 2 [list $writeslot -append $realprop] - uplevel 2 [list method $reader -unexport {} $getter] - uplevel 2 [list method $writer -unexport {value} $setter] - } - } - } - } - + namespace eval configuresupport { # ------------------------------------------------------------------ # # oo::configuresupport::configurableclass, @@ -583,27 +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 { - ::proc property args { - ::oo::configuresupport::PropertyImpl \ - ::oo::configuresupport::readableproperties \ - ::oo::configuresupport::writableproperties {*}$args - } + ::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 { - ::proc property args { - ::oo::configuresupport::PropertyImpl \ - ::oo::configuresupport::objreadableproperties \ - ::oo::configuresupport::objwritableproperties {*}$args - } + ::namespace eval configurableobject { # Plural alias just in case; deliberately NOT documented! ::proc properties args {::tailcall property {*}$args} ::namespace path ::oo::objdefine @@ -612,156 +512,15 @@ # ------------------------------------------------------------------ # - # oo::configuresupport::ReadAll -- - # - # The implementation of [$o configure] with no extra arguments. - # - # ------------------------------------------------------------------ - - proc ReadAll {object my} { - set result {} - foreach prop [info object properties $object -all -readable] { - try { - dict set result $prop [$my <ReadProp$prop>] - } on error {msg opt} { - dict set opt -level 2 - return -options $opt $msg - } on return {msg opt} { - dict incr opt -level 2 - return -options $opt $msg - } on break {} { - return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ - "property getter for $prop did a break" - } on continue {} { - return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ - "property getter for $prop did a continue" - } - } - 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 properties $object -all -readable] - try { - set prop [prefix match -message "property" $props $propertyName] - } on error {msg} { - catch { - set wps [info object properties $object -all -writable] - set wprop [prefix match $wps $propertyName] - set msg "property \"$wprop\" is write only" - } - return -code error -level 2 -errorcode [list \ - TCL LOOKUP INDEX property $propertyName] $msg - } - try { - set value [$my <ReadProp$prop>] - } on error {msg opt} { - dict set opt -level 2 - return -options $opt $msg - } on return {msg opt} { - dict incr opt -level 2 - return -options $opt $msg - } on break {} { - return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ - "property getter for $prop did a break" - } on continue {} { - return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ - "property getter for $prop did a continue" - } - return $value - } - - # ------------------------------------------------------------------ - # - # oo::configuresupport::WriteMany -- - # - # The implementation of [$o configure -prop val ?-prop val...?]. - # - # ------------------------------------------------------------------ - - proc WriteMany {object my setterMap} { - set props [info object properties $object -all -writable] - foreach {prop value} $setterMap { - try { - set prop [prefix match -message "property" $props $prop] - } on error {msg} { - catch { - set rps [info object properties $object -all -readable] - set rprop [prefix match $rps $prop] - set msg "property \"$rprop\" is read only" - } - return -code error -level 2 -errorcode [list \ - TCL LOOKUP INDEX property $prop] $msg - } - try { - $my <WriteProp$prop> $value - } on error {msg opt} { - dict set opt -level 2 - return -options $opt $msg - } on return {msg opt} { - dict incr opt -level 2 - return -options $opt $msg - } on break {} { - return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ - "property setter for $prop did a break" - } on continue {} { - return -code error -level 2 -errorcode {TCL OO SHENANIGANS} \ - "property setter for $prop did a continue" - } - } - 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. + # The 'configure' method is in tclOOBasic.c. # # ------------------------------------------------------------------ - ::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 -export 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 ...?"] - } - } - + ::oo::define configurable { definitionnamespace -instance configurableobject definitionnamespace -class configurableclass } |