summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorfvogel <fvogelnew1@free.fr>2016-07-05 20:37:10 (GMT)
committerfvogel <fvogelnew1@free.fr>2016-07-05 20:37:10 (GMT)
commitc6333aba37203822399af655bd8eb008c6c154ec (patch)
tree717a2d871092be7784f49191159fe3eb3dfb9c50
parente28d7bfd6199766d14e5583fcf905289c6737c36 (diff)
parent2336f2329bfb57ef247c9fb277bb06fabf27f85f (diff)
downloadtk-c6333aba37203822399af655bd8eb008c6c154ec.zip
tk-c6333aba37203822399af655bd8eb008c6c154ec.tar.gz
tk-c6333aba37203822399af655bd8eb008c6c154ec.tar.bz2
Merged core-8-6-branch
-rw-r--r--library/megawidget.tcl169
1 files changed, 160 insertions, 9 deletions
diff --git a/library/megawidget.tcl b/library/megawidget.tcl
index 9b9be92..aeb1263 100644
--- a/library/megawidget.tcl
+++ b/library/megawidget.tcl
@@ -29,14 +29,13 @@ package require Tk 8.6
}
::oo::class create ::tk::MegawidgetClass {
- variable w hull OptionSpecification options IdleCallbacks
+ variable w hull options IdleCallbacks
constructor args {
# Extract the "widget name" from the object name
set w [namespace tail [self]]
# Configure things
- set OptionSpecification [my GetSpecs]
- my configure {*}$args
+ tclParseConfigSpec [my varname options] [my GetSpecs] "" $args
# Move the object out of the way of the hull widget
rename [self] _tmp
@@ -46,7 +45,7 @@ package require Tk 8.6
bind $hull <Destroy> [list [namespace which my] destroy]
# Rename things into their final places
- rename ::$w theFrame
+ rename ::$w theWidget
rename [self] ::$w
# Make the contents
@@ -63,28 +62,165 @@ package require Tk 8.6
}
}
+ ####################################################################
+ #
+ # 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 {
- tclParseConfigSpec [my varname options] $OptionSpecification "" $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 \
@@ -97,6 +233,15 @@ package require Tk 8.6
}
}
+####################################################################
+#
+# 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 {} {
@@ -107,12 +252,12 @@ package require Tk 8.6
}
method CreateHull {} {
set hull [::ttk::frame $w -cursor $options(-cursor)]
- trace add variable options(-cursor) write \
- [namespace code {my UpdateCursorOption}]
+ 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
}
@@ -121,6 +266,13 @@ package require Tk 8.6
}
}
+####################################################################
+#
+# 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 {} {
@@ -133,8 +285,7 @@ package require Tk 8.6
ttk::frame $w
set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)]
pack $hull -expand yes -fill both -ipadx 2 -ipady 2
- trace add variable options(-cursor) write \
- [namespace code {my UpdateCursorOption}]
+ my TraceOption -cursor UpdateCursorOption
}
}