Version 20 of Megawidgets with TclOO

Updated 2009-04-13 16:39:11 by gwl

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)


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 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
}

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 <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...


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 <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]
            }
            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
    }
}

Usage

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:

class subclass className ?definitionScript?

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.

mega::widget wrap widget as className ?definitionScript?

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.

widget configure ?option? ?value? ?option value…?
widget cget option

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.


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...

GWL: Suggestions:

  1. We invert this pages so that the discussion of the current proposal is at top, followed by the current take, ...
  2. Instead of using a binding to track the destruction of a widget, how about using a command delete/rename trace?