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