[ce92c79bc6] Improve the 'configure' method of the internal megawidget framework. Thanks to Schelte Bron for pointing out the problems with it.

1 files changed, 160 insertions, 9 deletions

diff --git a/library/megawidget.tcl b/library/megawidget.tcl
index 9b9be92..aeb1263 100644
--- a/library/megawidget.tcl
+++ b/library/megawidget.tcl
@@ -29,14 +29,13 @@ package require Tk 8.6
 }
 
 ::oo::class create ::tk::MegawidgetClass {
-    variable w hull OptionSpecification options IdleCallbacks
+    variable w hull options IdleCallbacks
     constructor args {
 	# Extract the "widget name" from the object name
 	set w [namespace tail [self]]
 
 	# Configure things
-	set OptionSpecification [my GetSpecs]
-	my configure {*}$args
+	tclParseConfigSpec [my varname options] [my GetSpecs] "" $args
 
 	# Move the object out of the way of the hull widget
 	rename [self] _tmp
@@ -46,7 +45,7 @@ package require Tk 8.6
 	bind $hull <Destroy> [list [namespace which my] destroy]
 
 	# Rename things into their final places
-	rename ::$w theFrame
+	rename ::$w theWidget
 	rename [self] ::$w
 
 	# Make the contents
@@ -63,28 +62,165 @@ package require Tk 8.6
 	}
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::configure --
+    #
+    #	Implementation of 'configure' for megawidgets. Emulates the operation
+    #	of the standard Tk configure method fairly closely, which makes things
+    #	substantially more complex than they otherwise would be.
+    #
+    #	This method assumes that the 'GetSpecs' method returns a description
+    #	of all the specifications of the options (i.e., as Tk returns except
+    #	with the actual values removed). It also assumes that the 'options'
+    #	array in the class holds all options; it is up to subclasses to set
+    #	traces on that array if they want to respond to configuration changes.
+    #
+    #	TODO: allow unambiguous abbreviations.
+    #
     method configure args {
-	tclParseConfigSpec [my varname options] $OptionSpecification "" $args
+	# Configure behaves differently depending on the number of arguments
+	set argc [llength $args]
+	if {$argc == 0} {
+	    return [lmap spec [my GetSpecs] {
+		lappend spec $options([lindex $spec 0])
+	    }]
+	} elseif {$argc == 1} {
+	    set opt [lindex $args 0]
+	    if {[info exists options($opt)]} {
+		set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]
+		return [linsert $spec end $options($opt)]
+	    }
+	} elseif {$argc == 2} {
+	    # Special case for where we're setting a single option. This
+	    # avoids some of the costly operations. We still do the [array
+	    # get] as this gives a sufficiently-consistent trace.
+	    set opt [lindex $args 0]
+	    if {[dict exists [array get options] $opt]} {
+		# Actually set the new value of the option. Use a catch to
+		# allow a megawidget user to throw an error from a write trace
+		# on the options array to reject invalid values.
+		try {
+		    array set options $args
+		} on error {ret info} {
+		    # Rethrow the error to get a clean stack trace
+		    return -code error -errorcode [dict get $info -errorcode] $ret
+		}
+		return
+	    }
+	} elseif {$argc % 2 == 0} {
+	    # Check that all specified options exist. Any unknown option will
+	    # cause the merged dictionary to be bigger than the options array
+	    set merge [dict merge [array get options] $args]
+	    if {[dict size $merge] == [array size options]} {
+		# Actually set the new values of the options. Use a catch to
+		# allow a megawidget user to throw an error from a write trace
+		# on the options array to reject invalid values
+		try {
+		    array set options $args
+		} on error {ret info} {
+		    # Rethrow the error to get a clean stack trace
+		    return -code error -errorcode [dict get $info -errorcode] $ret
+		}
+		return
+	    }
+	    # Due to the order of the merge, the unknown options will be at
+	    # the end of the dict. This makes the first unknown option easy to
+	    # find.
+	    set opt [lindex [dict keys $merge] [array size options]]
+	} else {
+	    set opt [lindex $args end]
+	    return -code error -errorcode [list TK VALUE_MISSING] \
+		"value for \"$opt\" missing"
+	}
+	return -code error -errorcode [list TK LOOKUP OPTION $opt] \
+	    "bad option \"$opt\": must be [tclListValidFlags options]"
     }
+
+    ####################################################################
+    #
+    # MegawidgetClass::cget --
+    #
+    #	Implementation of 'cget' for megawidgets. Emulates the operation of
+    #	the standard Tk cget method fairly closely.
+    #
+    #	This method assumes that the 'options' array in the class holds all
+    #	options; it is up to subclasses to set traces on that array if they
+    #	want to respond to configuration reads.
+    #
+    #	TODO: allow unambiguous abbreviations.
+    #
     method cget option {
 	return $options($option)
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::TraceOption --
+    #
+    #	Sets up the tracing of an element of the options variable.
+    #
+    method TraceOption {option method args} {
+	set callback [list my $method {*}$args]
+	trace add variable options($option) write [namespace code $callback]
+    }
+
+    ####################################################################
+    #
+    # MegawidgetClass::GetSpecs --
+    #
+    #	Return a list of descriptions of options supported by this
+    #	megawidget. Each option is described by the 4-tuple list, consisting
+    #	of the name of the option, the "option database" name, the "option
+    #	database" class-name, and the default value of the option. These are
+    #	the same values returned by calling the configure method of a widget,
+    #	except without the current values of the options.
+    #
     method GetSpecs {} {
 	return {
 	    {-takefocus takeFocus TakeFocus {}}
 	}
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::CreateHull --
+    #
+    #	Creates the real main widget of the megawidget. This is often a frame
+    #	or toplevel widget, but isn't always (lightweight megawidgets might
+    #	use a content widget directly).
+    #
+    #	The name of the hull widget is given by the 'w' instance variable. The
+    #	name should be written into the 'hull' instance variable. The command
+    #	created by this method will be renamed.
+    #
     method CreateHull {} {
 	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
 	    "method must be overridden"
     }
+
+    ####################################################################
+    #
+    # MegawidgetClass::Create --
+    #
+    #	Creates the content of the megawidget. The name of the widget to
+    #	create the content in will be in the 'hull' instance variable.
+    #
     method Create {} {
 	return -code error -errorcode {TCL OO ABSTRACT_METHOD} \
 	    "method must be overridden"
     }
 
+    ####################################################################
+    #
+    # MegawidgetClass::WhenIdle --
+    #
+    #	Arrange for a method to be called on the current instance when Tk is
+    #	idle. Only one such method call per method will be queued; subsequent
+    #	queuing actions before the callback fires will be silently ignored.
+    #	The additional args will be passed to the callback, and the callbacks
+    #	will be properly cancelled if the widget is destroyed.
+    #
     method WhenIdle {method args} {
 	if {![info exists IdleCallbacks($method)]} {
 	    set IdleCallbacks($method) [after idle [list \
@@ -97,6 +233,15 @@ package require Tk 8.6
     }
 }
 
+####################################################################
+#
+# tk::SimpleWidget --
+#
+#	Simple megawidget class that makes it easy create widgets that behave
+#	like a ttk widget. It creates the hull as a ttk::frame and maps the
+#	state manipulation methods of the overall megawidget to the equivalent
+#	operations on the ttk::frame.
+#
 ::tk::Megawidget create ::tk::SimpleWidget {} {
     variable w hull options
     method GetSpecs {} {
@@ -107,12 +252,12 @@ package require Tk 8.6
     }
     method CreateHull {} {
 	set hull [::ttk::frame $w -cursor $options(-cursor)]
-	trace add variable options(-cursor) write \
-	    [namespace code {my UpdateCursorOption}]
+	my TraceOption -cursor UpdateCursorOption
     }
     method UpdateCursorOption args {
 	$hull configure -cursor $options(-cursor)
     }
+    # Not fixed names, so can't forward
     method state args {
 	tailcall $hull state {*}$args
     }
@@ -121,6 +266,13 @@ package require Tk 8.6
     }
 }
 
+####################################################################
+#
+# tk::FocusableWidget --
+#
+#	Simple megawidget class that makes a ttk-like widget that has a focus
+#	ring.
+#
 ::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {
     variable w hull options
     method GetSpecs {} {
@@ -133,8 +285,7 @@ package require Tk 8.6
 	ttk::frame $w
 	set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
 	pack $hull -expand yes -fill both -ipadx 2 -ipady 2
-	trace add variable options(-cursor) write \
-	    [namespace code {my UpdateCursorOption}]
+	my TraceOption -cursor UpdateCursorOption
     }
 }