summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl')
-rw-r--r--Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl297
1 files changed, 297 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl b/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl
new file mode 100644
index 00000000000..aeb1263a8c7
--- /dev/null
+++ b/Master/tlpkg/tltcl/lib/tk8.6/megawidget.tcl
@@ -0,0 +1,297 @@
+# 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: