diff options
Diffstat (limited to 'library/megawidget.tcl')
| -rw-r--r-- | library/megawidget.tcl | 169 |
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 } } |