package require tk



::oo::class create ::tk::Megawidget {

superclass ::oo::class

method unknown {w args} {

if {[string match .* $w]} {

[self] create $w {*}$args

return $w

}

next $w {*}$args

}

unexport new unknown

self method create {name superclasses body} {

next $name [list \

superclass ::tk::MegawidgetClass {*}$superclasses]\;$body

}

}

::oo::class create ::tk::MegawidgetClass {

variable w hull options IdleCallbacks

constructor args {

# Extract the "widget name" from the object name

set w [namespace tail [self]]

# Configure things

tclParseConfigSpec [my varname options] [my GetSpecs] "" $args

# Move the object out of the way of the hull widget

rename [self] _tmp

# Make the hull widget(s)

my CreateHull

bind $hull <Destroy> [list [namespace which my] destroy]

# Rename things into their final places

rename ::$w theWidget

rename [self] ::$w

# Make the contents

my Create

}

destructor {

foreach {name cb} [array get IdleCallbacks] {

after cancel $cb

unset IdleCallbacks($name)

}

if {[winfo exists $w]} {

bind $hull <Destroy> {}

destroy $w

}

}

####################################################################

#

# MegawidgetClass::configure --

#

# Implementation of 'configure' for megawidgets. Emulates the operation

# of the standard Tk configure method fairly closely, which makes things

# substantially more complex than they otherwise would be.

#

# This method assumes that the 'GetSpecs' method returns a description

# of all the specifications of the options (i.e., as Tk returns except

# with the actual values removed). It also assumes that the 'options'

# array in the class holds all options; it is up to subclasses to set

# traces on that array if they want to respond to configuration changes.

#

# TODO: allow unambiguous abbreviations.

#

method configure args {

# Configure behaves differently depending on the number of arguments

set argc [llength $args]

if {$argc == 0} {

return [lmap spec [my GetSpecs] {

lappend spec $options([lindex $spec 0])

}]

} elseif {$argc == 1} {

set opt [lindex $args 0]

if {[info exists options($opt)]} {

set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt]

return [linsert $spec end $options($opt)]

}

} elseif {$argc == 2} {

# Special case for where we're setting a single option. This

# avoids some of the costly operations. We still do the [array

# get] as this gives a sufficiently-consistent trace.

set opt [lindex $args 0]

if {[dict exists [array get options] $opt]} {

# Actually set the new value of the option. Use a catch to

# allow a megawidget user to throw an error from a write trace

# on the options array to reject invalid values.

try {

array set options $args

} on error {ret info} {

# Rethrow the error to get a clean stack trace

return -code error -errorcode [dict get $info -errorcode] $ret

}

return

}

} elseif {$argc % 2 == 0} {

# Check that all specified options exist. Any unknown option will

# cause the merged dictionary to be bigger than the options array

set merge [dict merge [array get options] $args]

if {[dict size $merge] == [array size options]} {

# Actually set the new values of the options. Use a catch to

# allow a megawidget user to throw an error from a write trace

# on the options array to reject invalid values

try {

array set options $args

} on error {ret info} {

# Rethrow the error to get a clean stack trace

return -code error -errorcode [dict get $info -errorcode] $ret

}

return

}

# Due to the order of the merge, the unknown options will be at

# the end of the dict. This makes the first unknown option easy to

# find.

set opt [lindex [dict keys $merge] [array size options]]

} else {

set opt [lindex $args end]

return -code error -errorcode [list TK VALUE_MISSING] \

"value for \"$opt\" missing"

}

return -code error -errorcode [list TK LOOKUP OPTION $opt] \

"bad option \"$opt\": must be [tclListValidFlags options]"

}

####################################################################

#

# MegawidgetClass::cget --

#

# Implementation of 'cget' for megawidgets. Emulates the operation of

# the standard Tk cget method fairly closely.

#

# This method assumes that the 'options' array in the class holds all

# options; it is up to subclasses to set traces on that array if they

# want to respond to configuration reads.

#

# TODO: allow unambiguous abbreviations.

#

method cget option {

return $options($option)

}

####################################################################

#

# MegawidgetClass::TraceOption --

#

# Sets up the tracing of an element of the options variable.

#

method TraceOption {option method args} {

set callback [list my $method {*}$args]

trace add variable options($option) write [namespace code $callback]

}

####################################################################

#

# MegawidgetClass::GetSpecs --

#

# Return a list of descriptions of options supported by this

# megawidget. Each option is described by the 4-tuple list, consisting

# of the name of the option, the "option database" name, the "option

# database" class-name, and the default value of the option. These are

# the same values returned by calling the configure method of a widget,

# except without the current values of the options.

#

method GetSpecs {} {

return {

{-takefocus takeFocus TakeFocus {}}

}

}

####################################################################

#

# MegawidgetClass::CreateHull --

#

# Creates the real main widget of the megawidget. This is often a frame

# or toplevel widget, but isn't always (lightweight megawidgets might

# use a content widget directly).

#

# The name of the hull widget is given by the 'w' instance variable. The

# name should be written into the 'hull' instance variable. The command

# created by this method will be renamed.

#

method CreateHull {} {

return -code error -errorcode {TCL OO ABSTRACT_METHOD} \

"method must be overridden"

}

####################################################################

#

# MegawidgetClass::Create --

#

# Creates the content of the megawidget. The name of the widget to

# create the content in will be in the 'hull' instance variable.

#

method Create {} {

return -code error -errorcode {TCL OO ABSTRACT_METHOD} \

"method must be overridden"

}

####################################################################

#

# MegawidgetClass::WhenIdle --

#

# Arrange for a method to be called on the current instance when Tk is

# idle. Only one such method call per method will be queued; subsequent

# queuing actions before the callback fires will be silently ignored.

# The additional args will be passed to the callback, and the callbacks

# will be properly cancelled if the widget is destroyed.

#

method WhenIdle {method args} {

if {![info exists IdleCallbacks($method)]} {

set IdleCallbacks($method) [after idle [list \

[namespace which my] DoWhenIdle $method $args]]

}

}

method DoWhenIdle {method arguments} {

unset IdleCallbacks($method)

tailcall my $method {*}$arguments

}

}

::tk::Megawidget create ::tk::SimpleWidget {} {

variable w hull options

method GetSpecs {} {

return {

{-cursor cursor Cursor {}}

{-takefocus takeFocus TakeFocus {}}

}

}

method CreateHull {} {

set hull [::ttk::frame $w -cursor $options(-cursor)]

my TraceOption -cursor UpdateCursorOption

}

method UpdateCursorOption args {

$hull configure -cursor $options(-cursor)

}

# Not fixed names, so can't forward

method state args {

tailcall $hull state {*}$args

}

method instate args {

tailcall $hull instate {*}$args

}

}

::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget {

variable w hull options

method GetSpecs {} {

return {

{-cursor cursor Cursor {}}

{-takefocus takeFocus TakeFocus ::ttk::takefocus}

}

}

method CreateHull {} {

ttk::frame $w

set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]

pack $hull -expand yes -fill both -ipadx 1.5p -ipady 1.5p

my TraceOption -cursor UpdateCursorOption

}

}