summaryrefslogtreecommitdiffstats
path: root/library/megawidget.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/megawidget.tcl')
-rw-r--r--library/megawidget.tcl140
1 files changed, 140 insertions, 0 deletions
diff --git a/library/megawidget.tcl b/library/megawidget.tcl
new file mode 100644
index 0000000..1cd2900
--- /dev/null
+++ b/library/megawidget.tcl
@@ -0,0 +1,140 @@
+# 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 OptionSpecification 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
+
+ # 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 theFrame
+ 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
+ }
+ }
+
+ method configure args {
+ tclParseConfigSpec [my varname options] $OptionSpecification "" $args
+ }
+ method cget option {
+ return $options($option)
+ }
+
+ method GetSpecs {} {
+ return {
+ {-takefocus takeFocus TakeFocus {}}
+ }
+ }
+
+ method CreateHull {} {error "method must be overridden"}
+ method Create {} {error "method must be overridden"}
+
+ 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)]
+ trace add variable options(-cursor) write \
+ [namespace code {my UpdateCursorOption}]
+ }
+ method UpdateCursorOption args {
+ $hull configure -cursor $options(-cursor)
+ }
+ 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 2 -ipady 2
+ trace add variable options(-cursor) write \
+ [namespace code {my UpdateCursorOption}]
+ }
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End: