Implementation of properties for TclOO

1 files changed, 114 insertions, 0 deletions

diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index a1e4624..c8a79a9 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -248,6 +248,120 @@ static const char *tclOOSetupScript =
 "\t\tsuperclass class\n"
 "\t\tunexport create createWithNamespace new\n"
 "\t}\n"
+"\tnamespace eval configuresupport {\n"
+"\t\tproc property {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"
+"\t\t\t\t\treturn -code error -errorcode {TCLOO PROPERTY_FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad property name \\\"$prop\\\"; must not begin with -\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
+"\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\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"
+"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
+"\t\t\t\t\t\t\t\treturn -code error -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 -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 getter $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 -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 [::tcl::prefix match -message \"kind\" {\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\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 <ReadProp$realprop> {} $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 <WriteProp$realprop> {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 <ReadProp$realprop> {} $getter]\n"
+"\t\t\t\t\t\tuplevel 1 [list method <WriteProp$realprop> {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\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}\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\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}\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"
+"\t\t\t::tcl::prefix match -message \"property\" $props $prop\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 <ReadProp$prop>]\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 <ReadProp$prop>]\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 <WriteProp$prop> $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}\n"
+"\t}\n"
 "}\n"
 /* !END!: Do not edit above this line. */
 ;