[DKF]: The content of this page represents a first reasonably-serious attempt at doing [megawidget]s with [TclOO]. ([Bryan Oakley]: for another take on the subject see [Read-Only Text Megawidget with TclOO]) ---- **Take 1** The example code below comes in two parts, a pair of classes that represent how to build a megawidget (i.e. the class of factories of [widget]s, and the class of widgets), and some demonstration code. The demo code builds an extended [frame] that supports two extra methods: '''change''' which alters the background colour of the widget, and '''flash''' which makes the widget highly visible for a bit. It also brings a [ttk::button] into the framework, which is a reasonably severe test of the embedding code. It finally does a tiny demo usage of the code; click on the frame to make it flash, and click the button twice to exit (or just kill the window using your window manager; that works as normal). ---- ====== package require Tk package require Ttk package require TclOO 0.3a0 oo::class create widgetFactory { superclass oo::class constructor {underlying methods properties definitionScript} { next $definitionScript my variable u m p set u $underlying set m $methods set p $properties } method getUnderlying {} { my variable u return $u } method getMethods {} { my variable m return $m } method getProperties {} { my variable p return $p } method unknown {args} { if {[string match .* [lindex $args 0]]} { return [uplevel 1 [list [self] create {*}$args]] } next {*}$args } unexport unknown } oo::class create widget { # Note that we are not using the standard 'create' method! self { unexport create method createSubclass {name underlying {definitionScript {}}} { set script "[list superclass [self]];$definitionScript" # Discover what methods are supported by the underlying widget $underlying .____ catch {.____ ?} msg set props [.____ configure] destroy .____ regexp {: must be (.*)} $msg -> opts regsub -all {, |,? or } $opts { } m foreach prop $props { lappend p [lindex $prop 0] } uplevel 1 [list \ widgetFactory create $name $underlying $m $p $script] } } unexport destroy method Class {args} {[info object class [self]] {*}$args} constructor {args} { my variable w props set props {} set underlying [my Class getUnderlying] set pathName [namespace tail [self]] rename [self] __tmp set w _$pathName # TODO: filter for props that are not accepted by underlying set pathName [uplevel 1 [list $underlying $pathName {*}$args]] uplevel 1 [list rename $pathName $w] uplevel 1 [list rename [self] $pathName] return $pathName } method cget property { my variable w props if {[dict exists $props $property]} { return [dict get $props $property] } $w cget $property } method configure {args} { my variable w props set p [my Class getProperties] if {[llength $args] == 0} { # TODO: Make this work right! return [lsort [concat $p [dict keys $props]]] } foreach {property value} $args { if {$property in $p} { $w configure $property $value } else { dict set props $property $value } } # TODO: make this work correctly the other ways configure methods # classically work } method unknown {method args} { my variable w if {$method in [my Class getMethods]} { oo::objdefine [self] forward $method $w $method return [$w $method {*}$args] } return -code error "unknown subcommand \"$method\": must be one of FIXME" } } # Demonstrate by making an extended frame widget widget createSubclass FlashingFrame frame { constructor args { next {*}$args my variable flashing set flashing 0 [self] configure -colour1 white -colour2 black -time0 100 \ -time1 50 -time2 50 -iterations 4 } method change color { [self] configure -bg $color } method flash {} { my variable flashing if {!$flashing} { set w [self] set c [$w cget -bg] set flashing 1 set t [expr {-[$w cget -time0]}] for {set i 0} {$i<[$w cget -iterations]} {incr i} { incr t [$w cget -time0] after $t $w change [$w cget -colour1] incr t [$w cget -time1] after $t $w change [$w cget -colour2] incr t [$w cget -time2] after $t $w change $c } after $t [namespace code {my EndFlashing}] } } method EndFlashing {} { my variable flashing set flashing 0 } } # Tests method forwarding; no new methods defined widget createSubclass Button ttk::button # Put the FlashingFrame through its paces FlashingFrame .f -background red -width 100 -height 100 Button .b -text bye -command { .b configure -command exit tk_messageBox -message "press again to exit" } pack .f .b after 500 .f change green bind .f <1> { %W flash } ====== ---- ***Discussion*** '''[DGP]''' I'm not very close to this subject, so my impressions may be mistaken, but I've thought one of the virtues sought in a megawidget system was that the script-defined megawidgets got used the same way as the built-in C-coded base widget set, so that scripts could use both kinds of widget commands without being bothered to know which was which, and so that megawidget creators could make things on the same level as the original commands just as [proc] writers produce commands which take their place on an even playing field with the Tcl built-in commands. However, I see FlashingFrame create .f ... And I know that the base Tk widget looks like: frame .f ... Is this an indcation that TclOO has some issues serving as ''the'' base for Tk megawidgets? [DKF]: No; it should be fine. It just requires an unknown handler on the `widgetFactory` that redirects unknown calls to methods beginning with a period to the instantiation method. ''(Now added)'' ---- [mpdanielson]: The above code doesn't keep the association between the widget and the wrapper class when one or the other is destroyed. If the widget is destroyed with "destroy .widget", the wrapper class persists. If the wrapper is destroyed with ".widget destroy", the widget persists. This leads to odd behavior later on. One, rather fragile, way to avoid this is as follows: constructor { args } { ... ;# coded as above # add a binding to catch the widget destruction # bind still operates on the original name, regardless of the rename bind $pathName [list $pathName destroy] return $pathName } # add a destructor to clean up the widget destructor { set w [namespace tail [self]] ;# the variable w has the wrong name for bind catch {bind $w {}} ;# remove the binding to avoid recursive destroys catch {destroy $w} ;# make sure the Tk widget is destroyed catch next ;# the manual says to call next, but it raises an error... } This works, but is susceptible to being accidentally removed when another binding to is set on the widget, by somebody not expecting a prior binding to be in place. I can't think of anything better that doesn't require C, but maybe somebody brighter than me can suggest something :) [DKF]: Getting this sort of detail right is where megawidget writing gets tiresome and makes me think that Tk's support is not yet good enough. The best way to deal with the issue you raise is almost certainly to use the [bindtags] command to add another binding tag to the widget (maybe your own additional "class"-like tag?) and put the internal binding on that. This has the additional advantage of being much easier to work with if you're wrapping a [toplevel] widget, as the will then only get delivered once... ---- **Take 2** This is my second attempt at a small megawidget framework. This does the things required to allow the embedding of arbitrary widgets, uses events to clean up the object when the widget is destroyed and ''vice versa'', and allows you to use variable traces to respond to the setting of configuration options. It also includes convenience methods for creating subclasses and for manufacturing a subclass from an existing widget. This code needs the HEAD as of at least 11 April 2009. ---- ====== package require Tcl 8.6 package require Tk namespace eval ::mega { namespace path ::oo class create WidgetFactory { superclass class method unknown {w args} { if {[string match .* $w]} { [self] create $w {*}$args return $w } next $w {*}$args } method subclass {name {script {}}} { tailcall [self class] create $name \ "superclass [list [self]];$script" } method wrap {realWidget as name {script {}}} { if {$as ne "as"} {error "'as' should be a literal"} set w [$realWidget .__] set aliases {} set defs {} foreach tuple [$w configure] { if {[llength $tuple] == 2} { lappend aliases {*}$tuple } else { dict set defs [lindex $tuple 0] [lrange $tuple 1 3] } } catch {$w ???} msg regexp {^bad (?:command|option) ".*": must be (.*)} $msg -> msg destroy $w set cmds [regsub -all {, (or )?} $msg { }] set script1 [format { superclass ::mega::WidgetWrapper method AliasOptions {} {dict merge [next] %s} method DefaultOptions {} {dict merge [next] %s} method Create args { variable w %s $w {*}$args next } } [list $aliases] [list $defs] [list $realWidget]] foreach cmd $cmds { if {$cmd ni {configure cget}} { append script1 [format { forward %1$s widget %1$s } [list $cmd]] } } tailcall [self class] create $name $script1$script } unexport new unknown } WidgetFactory create widget { variable w options optionAliases constructor args { set w [namespace tail [self]] rename [self] _ my Create rename ::$w widget rename [self] ::$w set optionAliases [my AliasOptions] dict for {opt def} [my DefaultOptions] { set val {} lassign $def name class default if {$name ne ""} { set val [option get $w $name $class] } if {$val eq ""} { set val $default } set options($opt) [list $opt $name $class $default $val] } my configure {*}$args bindtags $w [list DestroyTrack$w {*}[bindtags $w]] bind DestroyTrack$w [namespace code {my destroy}] } destructor { if {[winfo exists $w]} { bind DestroyTrack$w {} destroy $w } } method Create {} { frame $w } method DefaultOptions {} { } method AliasOptions {} { } method configure args { if {[llength $args] == 0} { set result {} foreach opt [lsort [concat \ [dict keys $optionAliases] [array names options]]] { if {[dict exists $optionAliases $opt]} { lappend result [list $opt [dict get $optionAliases $opt]] } else { lappend result $options($opt) } } return $result } elseif {[llength $args] == 1} { set opt [lindex $args 0] if {[dict exists $optionAliases $opt]} { set opt [dict get $optionAliases $opt] } return $options($opt) } elseif {[llength $args] % 1} { return -code error "value for \"[lindex $args end]\" missing" } set opts {} foreach {option value} $args { if {[dict exists $optionAliases $option]} { set option [dict get $optionAliases $option] } if {![info exists options($option)]} { return -code error "unknown option \"$option\"" } set l $options($option) lset l 4 $value dict set opts $option $l } set old [array get options] try { array set options $opts } on error {msg opt} { foreach {o v} $old {catch {set options($o) $v}} return -options $opt $msg } return } method cget option { if {[dict exists $optionAliases $option]} { set option [dict get $optionAliases] } return [lindex $options($option) end] } } WidgetFactory create WidgetWrapper { superclass widget method Create {} { variable options trace add variable options write [namespace code {my Set}] } method Set {_ opt _} { variable options widget configure $opt [lindex $options($opt) end] } self unexport wrap } } ====== ---- ***Examples*** Create a button with an extra method: ====== mega::widget wrap ::button as DemoButton { variable w method swap {} { $w configure -fg [$w cget -bg] -bg [$w cget -fg] } } ====== Create a custom frame class "manually": ====== mega::widget subclass DemoFrame { variable w options ready createOptions constructor args { # Special hack; frame widgets have options only settable at # creation time... set createOptions {} if {[llength $args] & 1 == 0} { foreach {opt val} $args { if {$opt in {-class -container -colormap -visual}} { lappend createOptions $opt $val } } } set ready 0 next {*}$args set ready 1 } # We're doing the options "manually" for demonstration purposes, so we # need to do these next few methods... # This method returns a dictionary that maps short option names to their # long versions method AliasOptions {} { dict merge [next] { -bd -borderwidth -bg -background } } # This method returns a dictionary that maps option names to their option # names, classes and default values method DefaultOptions {} { dict merge [next] { -borderwidth {borderWidth BorderWidth 0} -class {class Class Frame} -relief {relief Relief flat} -background {background Background #d9d9d9} -colormap {colormap Colormap {}} -container {container Container 0} -cursor {cursor Cursor {}} -height {height Height 0} -highlightbackground \ {highlightBackground HighlightBackground #d9d9d9} -highlightcolor {highlightColor HighlightColor #000000} -highlightthickness {highlightThickness HighlightThickness 0} -padx {padX Pad 0} -pady {padY Pad 0} -takefocus {takeFocus TakeFocus 0} -visual {visual Visual {}} -width {width Width 0} } } # Create the underlying widget and attach a whole-array trace that reflects # all settable options onto the underlying widget method Create {} { frame $w {*}$createOptions trace add variable options write [namespace code {my Set}] } # Implementation of the setter callback; skips read-only options at the # critical widget creation time method Set {_ opt _} { if {!$ready && $opt in {-class -container -colormap -visual}} { return } widget configure $opt [lindex $options($opt) end] } } ====== ---- ***Discussion*** [DKF]: These things are not yet as elegant as I'd like. In particular: * doing the configuration options is an ugly business (OK, that's not really surprising; it's pretty ugly in C too once you look inside the API), and * Also, variable declarations are not quite as useful as they should be; perhaps should consider the "slot" concept used by [XOTcl] here. I left some things out, notably: * type constraints of options (should be doable with a write [trace]) [AK]: Regarding "allows you to use variable traces to respond to the setting of configuration options" I wonder if that is a good idea, given that var traces are one of the heavy dynamic features of Tcl which make the optimization of execution difficult. [DKF]: While yes, they do cause issues with performance, they have other benefits in that they make it far easier to tie various bits and pieces together. Without them, you have to build an explicit callback framework yourself... ---- !!!!!! %| [Category GUI] | [Category Object Orientation] | [Category Widget] |% !!!!!!