package require Tk
package require TclOO 0.3a0

oo::class create widgetFactory {
    superclass oo::class
    constructor {underlying methods definitionScript} {
	next $definitionScript
	my variable u m
	set u $underlying
	set m $methods
    }
    method getUnderlying {} {
	my variable u
	return $u
    }
    method getMethods {} {
	my variable m
	return $m
    }
    method unknown {args} {
	if {[string match .* [lindex $args 0]]} {
	    return [uplevel 1 [list [self] create {*}$args]]
	}
	next {*}$args
    }
}
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
	    destroy .____
	    regexp {: must be (.*)} $msg -> opts
	    regsub -all {, | or |} $opts {} m

	    uplevel 1 [list widgetFactory create $name $underlying $m $script]
	}
    }
    constructor {args} {
	my variable w props
	set props {}
	# Don't use [self class]; need the actual class of the object
	set class [info object class [self]]

	set underlying [$class getUnderlying]
	set pathName [namespace tail [self]]
	rename [self] __tmp
	set w _$pathName
	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 {property value} {
	my variable w props
	if {[catch {$w configure $property $value}]} {
	    dict set props $property $value
	}
	return $value
    }
    method unknown {method args} {
	my variable w
	set class [info object class [self]]
	if {$method in [$class getMethods]} {
	    oo::objdefine [self] forward $method $w $method
	    $w $method {*}$args
	}
    }
}

# Demonstrate by making an extended frame widget
widget createSubclass FlashingFrame frame {
    constructor args {
	next {*}$args
	my variable flashing
	set flashing 0
    }
    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
	    after 0   $w change white
	    after 50  $w change black
	    after 100 $w change $c
	    after 200 $w change white
	    after 250 $w change black
	    after 300 $w change $c
	    after 400 $w change white
	    after 450 $w change black
	    after 500 $w change $c
	    after 600 $w change white
	    after 650 $w change black
	    after 700 $w change $c
	    after 700 [namespace code {my EndFlashing}]
	}
    }
    method EndFlashing {} {
	my variable flashing
	set flashing 0
    }
}

# Put the FlashingFrame through its paces
FlashingFrame .f -background red -width 100 -height 100
pack .f

after 500 .f change green
bind .f <1> {
    %W flash
}