diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/button.tcl | 19 | ||||
| -rw-r--r-- | library/demos/ixset | 1 | ||||
| -rw-r--r-- | library/demos/rmt | 1 | ||||
| -rw-r--r-- | library/demos/states.tcl | 11 | ||||
| -rw-r--r-- | library/demos/timer | 1 | ||||
| -rw-r--r-- | library/demos/widget | 1 | ||||
| -rw-r--r-- | library/megawidget.tcl | 169 | ||||
| -rw-r--r-- | library/scrlbar.tcl | 11 | ||||
| -rw-r--r-- | library/spinbox.tcl | 54 | ||||
| -rw-r--r-- | library/tk.tcl | 4 | ||||
| -rw-r--r-- | library/ttk/menubutton.tcl | 2 |
11 files changed, 237 insertions, 37 deletions
diff --git a/library/button.tcl b/library/button.tcl index b2bafb2..80d8bf9 100644 --- a/library/button.tcl +++ b/library/button.tcl @@ -597,12 +597,25 @@ proc ::tk::ButtonUp w { # w - The name of the widget. proc ::tk::ButtonInvoke w { - if {[$w cget -state] ne "disabled"} { + if {[winfo exists $w] && [$w cget -state] ne "disabled"} { set oldRelief [$w cget -relief] set oldState [$w cget -state] $w configure -state active -relief sunken - update idletasks - after 100 + after 100 [list ::tk::ButtonInvokeEnd $w $oldState $oldRelief] + } +} + +# ::tk::ButtonInvokeEnd -- +# The procedure below is called after a button is invoked through +# the keyboard. It simulate a release of the button via the mouse. +# +# Arguments: +# w - The name of the widget. +# oldState - Old state to be set back. +# oldRelief - Old relief to be set back. + +proc ::tk::ButtonInvokeEnd {w oldState oldRelief} { + if {[winfo exists $w]} { $w configure -state $oldState -relief $oldRelief uplevel #0 [list $w invoke] } diff --git a/library/demos/ixset b/library/demos/ixset index ee6e072..13235de 100644 --- a/library/demos/ixset +++ b/library/demos/ixset @@ -9,7 +9,6 @@ exec wish "$0" ${1+"$@"} # 91/11/23 : pda@masi.ibp.fr, jt@ratp.fr : design # 92/08/01 : pda@masi.ibp.fr : cleaning -package require Tcl 8.4 package require Tk # diff --git a/library/demos/rmt b/library/demos/rmt index 51886de..00bdc9d 100644 --- a/library/demos/rmt +++ b/library/demos/rmt @@ -7,7 +7,6 @@ exec wish "$0" ${1+"$@"} # Tk applications. It allows you to select an application and # then type commands to that application. -package require Tcl 8.4 package require Tk wm title . "Tk Remote Controller" diff --git a/library/demos/states.tcl b/library/demos/states.tcl index 92b1f1e..aeb3d5b 100644 --- a/library/demos/states.tcl +++ b/library/demos/states.tcl @@ -19,6 +19,17 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down." pack $w.msg -side top +labelframe $w.justif -text Justification +foreach c {Left Center Right} { + set lower [string tolower $c] + radiobutton $w.justif.$lower -text $c -variable just \ + -relief flat -value $lower -anchor w \ + -command "$w.frame.list configure -justify \$just" \ + -tristatevalue "multi" + pack $w.justif.$lower -side left -pady 2 -fill x +} +pack $w.justif + ## See Code / Dismiss buttons set btns [addSeeDismiss $w.buttons $w] pack $btns -side bottom -fill x diff --git a/library/demos/timer b/library/demos/timer index e10b840..6b61ca4 100644 --- a/library/demos/timer +++ b/library/demos/timer @@ -5,7 +5,6 @@ exec wish "$0" ${1+"$@"} # timer -- # This script generates a counter with start and stop buttons. -package require Tcl 8.4 package require Tk label .counter -text 0.00 -relief raised -width 10 -padx 2m -pady 1m diff --git a/library/demos/widget b/library/demos/widget index 7604341..1d838ad 100644 --- a/library/demos/widget +++ b/library/demos/widget @@ -10,7 +10,6 @@ exec wish "$0" ${1+"$@"} # separate ".tcl" files is this directory, which are sourced by this script as # needed. -package require Tcl 8.5 package require Tk 8.5 package require msgcat 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 } } diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index b7be014..6f1caa2 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -430,6 +430,9 @@ proc ::tk::ScrollTopBottom {w x y} { proc ::tk::ScrollButton2Down {w x y} { variable ::tk::Priv + if {![winfo exists $w]} { + return + } set element [$w identify $x $y] if {[string match {arrow[12]} $element]} { ScrollButtonDown $w $x $y @@ -443,7 +446,9 @@ proc ::tk::ScrollButton2Down {w x y} { # slider drag. update idletasks - $w configure -activerelief sunken - $w activate slider - ScrollStartDrag $w $x $y + if {[winfo exists $w]} { + $w configure -activerelief sunken + $w activate slider + ScrollStartDrag $w $x $y + } } diff --git a/library/spinbox.tcl b/library/spinbox.tcl index 6a5f829..1965ed8 100644 --- a/library/spinbox.tcl +++ b/library/spinbox.tcl @@ -86,10 +86,12 @@ bind Spinbox <B1-Motion> { ::tk::spinbox::Motion %W %x %y } bind Spinbox <Double-1> { + ::tk::spinbox::ArrowPress %W %x %y set tk::Priv(selectMode) word ::tk::spinbox::MouseSelect %W %x sel.first } bind Spinbox <Triple-1> { + ::tk::spinbox::ArrowPress %W %x %y set tk::Priv(selectMode) line ::tk::spinbox::MouseSelect %W %x 0 } @@ -299,6 +301,10 @@ bind Spinbox <B2-Motion> { proc ::tk::spinbox::Invoke {w elem} { variable ::tk::Priv + if {![winfo exists $w]} { + return + } + if {![info exists Priv(outsideElement)]} { $w invoke $elem incr Priv(repeated) @@ -328,6 +334,35 @@ proc ::tk::spinbox::ClosestGap {w x} { incr pos } +# ::tk::spinbox::ArrowPress -- +# This procedure is invoked to handle button-1 presses in buttonup +# or buttondown elements of spinbox widgets. +# +# Arguments: +# w - The spinbox window in which the button was pressed. +# x - The x-coordinate of the button press. +# y - The y-coordinate of the button press. + +proc ::tk::spinbox::ArrowPress {w x y} { + variable ::tk::Priv + + if {[$w cget -state] ne "disabled" && \ + [string match "button*" $Priv(element)]} { + $w selection element $Priv(element) + set Priv(repeated) 0 + set Priv(relief) [$w cget -$Priv(element)relief] + catch {after cancel $Priv(afterId)} + set delay [$w cget -repeatdelay] + if {$delay > 0} { + set Priv(afterId) [after $delay \ + [list ::tk::spinbox::Invoke $w $Priv(element)]] + } + if {[info exists Priv(outsideElement)]} { + unset Priv(outsideElement) + } + } +} + # ::tk::spinbox::ButtonDown -- # This procedure is invoked to handle button-1 presses in spinbox # widgets. It moves the insertion cursor, sets the selection anchor, @@ -336,6 +371,7 @@ proc ::tk::spinbox::ClosestGap {w x} { # Arguments: # w - The spinbox window in which the button was pressed. # x - The x-coordinate of the button press. +# y - The y-coordinate of the button press. proc ::tk::spinbox::ButtonDown {w x y} { variable ::tk::Priv @@ -350,20 +386,7 @@ proc ::tk::spinbox::ButtonDown {w x y} { switch -exact $Priv(element) { "buttonup" - "buttondown" { - if {"disabled" ne [$w cget -state]} { - $w selection element $Priv(element) - set Priv(repeated) 0 - set Priv(relief) [$w cget -$Priv(element)relief] - catch {after cancel $Priv(afterId)} - set delay [$w cget -repeatdelay] - if {$delay > 0} { - set Priv(afterId) [after $delay \ - [list ::tk::spinbox::Invoke $w $Priv(element)]] - } - if {[info exists Priv(outsideElement)]} { - unset Priv(outsideElement) - } - } + ::tk::spinbox::ArrowPress $w $x $y } "entry" { set Priv(selectMode) char @@ -388,6 +411,7 @@ proc ::tk::spinbox::ButtonDown {w x y} { # Arguments: # w - The spinbox window in which the button was pressed. # x - The x-coordinate of the button press. +# y - The y-coordinate of the button press. proc ::tk::spinbox::ButtonUp {w x y} { variable ::tk::Priv @@ -491,6 +515,8 @@ proc ::tk::spinbox::Paste {w x} { # # Arguments: # w - The spinbox window. +# x - The x-coordinate of the mouse. +# y - The y-coordinate of the mouse. proc ::tk::spinbox::Motion {w x y} { variable ::tk::Priv diff --git a/library/tk.tcl b/library/tk.tcl index 946ab7e..54d8ffb 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -10,10 +10,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# Insist on running with compatible version of Tcl -package require Tcl 8.6 # Verify that we have Tk binary and script components from the same release -package require -exact Tk 8.6.4 +package require -exact Tk 8.6.5 # Create a ::tk namespace namespace eval ::tk { diff --git a/library/ttk/menubutton.tcl b/library/ttk/menubutton.tcl index 093bb02..2be064c 100644 --- a/library/ttk/menubutton.tcl +++ b/library/ttk/menubutton.tcl @@ -57,7 +57,7 @@ if {[tk windowingsystem] eq "x11"} { bind TMenubutton <ButtonPress-1> \ { %W state pressed ; ttk::menubutton::Popdown %W } bind TMenubutton <ButtonRelease-1> \ - { %W state !pressed } + { if {[winfo exists %W]} { %W state !pressed } } } # PostPosition -- |