Property definitions now work on instances.

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 <ReadProp$prop>]\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 <ReadProp$prop>]\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 <ReadProp$prop>]\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 <WriteProp$prop> $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 <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::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 <ReadProp$prop>]
+	    }
+	    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 <ReadProp$prop>]
+	# 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 <ReadProp$prop>]
+	}
+
+	# ------------------------------------------------------------------
+	#
+	# 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 <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]
 		}
-		return $result
-	    } elseif {[llength $args] == 1} {
-		# Read a single property
-		set prop [my Configure:Match [lindex $args 0] -readable]
-		return [my <ReadProp$prop>]
-	    } elseif {[llength $args] % 2 == 0} {
-		# Set properties, one or several
-		foreach {prop value} $args {
-		    set prop [my Configure:Match $prop -writable]
-		    my <WriteProp$prop> $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
     }
 }