DKF: The content of this page represents a first reasonably-serious attempt at doing megawidgets with TclOO.
GWL: Note -- this page is in chronological order, i.e. the latest "Take" and "Discussion" are at the bottom of the page.
(Bryan Oakley: for another take on the subject see Read-Only Text Megawidget with TclOO)
(hypnotoad: For an entire framework built around TclOO as a megawidget set, see: taotk)
DKF: There is an evolution of this approach inside Tk (::tk::Megawidget) which is doing good already (supporting the standard dialogs) and is gradually evolving into the system which we want to have.
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 widgets, 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)
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 <Destroy> [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 <Destroy> {}} ;# 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 <Destroy> 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 <Destroy> binding on that. This has the additional advantage of being much easier to work with if you're wrapping a toplevel widget, as the <Destroy> will then only get delivered once...
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 <Destroy> [namespace code {my destroy}]
}
destructor {
if {[winfo exists $w]} {
bind DestroyTrack$w <Destroy> {}
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 $option]
}
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
}
}Only the class mega::widget is intended to be public. It is the class of all megawidgets, and includes all the (fairly complex) machinery to connect a widget to TclOO.
It has these public methods:
Create a subclass of the given widget class. This splices the class correctly into the rest of the megawidget system, and should be used in preference to the normal superclass definition. Optionally adds the given definitions to it.
Brings the named Tk or Ttk "widget class" into the megawidget system as a real class (by probing how a widget created through that command behaves). Optionally adds the given definitions to it.
Standard configuration methods. Options are defined by overriding the DefaultOptions and AliasOptions private methods, which take no arguments and return the definition dictionary and alias dictionary respectively (see below for examples of how to write them).
Two standard variables are defined:
| w | The path name of the widget. |
| options | Array of option tuples (the current value of an option being the last element in the tuple). |
The widget is actually created by calling the private Create method — only called during the execution of the constructor — and will end up (after the constructor finishes) with the name widget in the object's namespace.
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]
}
}DKF: These things are not yet as elegant as I'd like. In particular:
I left some things out, notably:
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...
RZ: Have a look on xotcl2/nsf for type constraints.
GWL: Suggestions:
DKF: A delete trace on widget? Doesn't sound like a bad idea, though it has the down-side of making the finalization order even more mind-bending...