[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]) 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 } ====== ---- '''[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)'' ---- !!!!!! %| [Category GUI] | [Category Object Orientation] | [Category Widget] |% !!!!!!