298 lines
9.3 KiB
Tcl
298 lines
9.3 KiB
Tcl
# megawidget.tcl
|
||
#
|
||
# Basic megawidget support classes. Experimental for any use other than
|
||
# the ::tk::IconList megawdget, which is itself only designed for use in
|
||
# the Unix file dialogs.
|
||
#
|
||
# Copyright (c) 2009-2010 Donal K. Fellows
|
||
#
|
||
# See the file "license.terms" for information on usage and redistribution of
|
||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
#
|
||
|
||
package require Tk 8.6
|
||
|
||
::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::SimpleWidget --
|
||
#
|
||
# Simple megawidget class that makes it easy create widgets that behave
|
||
# like a ttk widget. It creates the hull as a ttk::frame and maps the
|
||
# state manipulation methods of the overall megawidget to the equivalent
|
||
# operations on the ttk::frame.
|
||
#
|
||
::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::FocusableWidget --
|
||
#
|
||
# Simple megawidget class that makes a ttk-like widget that has a focus
|
||
# ring.
|
||
#
|
||
::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 2 -ipady 2
|
||
my TraceOption -cursor UpdateCursorOption
|
||
}
|
||
}
|
||
|
||
return
|
||
|
||
# Local Variables:
|
||
# mode: tcl
|
||
# fill-column: 78
|
||
# End:
|