Version 11 of Megawidgets with TclOO

Updated 2009-02-07 05:15:47 by mpdanielson

DKF: The content of this page represents a first reasonably-serious attempt at doing megawidgets 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 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 :)