diff options
Diffstat (limited to 'tk/library/button.tcl')
| -rw-r--r-- | tk/library/button.tcl | 515 |
1 files changed, 349 insertions, 166 deletions
diff --git a/tk/library/button.tcl b/tk/library/button.tcl index d930aee86ef..d92facfa902 100644 --- a/tk/library/button.tcl +++ b/tk/library/button.tcl @@ -8,6 +8,7 @@ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 2002 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -17,122 +18,123 @@ # The code below creates the default class bindings for buttons. #------------------------------------------------------------------------- -if {[string match "macintosh" $tcl_platform(platform)]} { +if {[string equal [tk windowingsystem] "classic"] + || [string equal [tk windowingsystem] "aqua"]} { bind Radiobutton <Enter> { - tkButtonEnter %W + tk::ButtonEnter %W } bind Radiobutton <1> { - tkButtonDown %W + tk::ButtonDown %W } bind Radiobutton <ButtonRelease-1> { - tkButtonUp %W + tk::ButtonUp %W } bind Checkbutton <Enter> { - tkButtonEnter %W + tk::ButtonEnter %W } bind Checkbutton <1> { - tkButtonDown %W + tk::ButtonDown %W } bind Checkbutton <ButtonRelease-1> { - tkButtonUp %W + tk::ButtonUp %W } } -if {[string match "windows" $tcl_platform(platform)]} { +if {[string equal "windows" $tcl_platform(platform)]} { bind Checkbutton <equal> { - tkCheckRadioInvoke %W select + tk::CheckRadioInvoke %W select } bind Checkbutton <plus> { - tkCheckRadioInvoke %W select + tk::CheckRadioInvoke %W select } bind Checkbutton <minus> { - tkCheckRadioInvoke %W deselect + tk::CheckRadioInvoke %W deselect } bind Checkbutton <1> { - tkCheckRadioDown %W + tk::CheckRadioDown %W } bind Checkbutton <ButtonRelease-1> { - tkButtonUp %W + tk::ButtonUp %W } bind Checkbutton <Enter> { - tkCheckRadioEnter %W + tk::CheckRadioEnter %W } bind Radiobutton <1> { - tkCheckRadioDown %W + tk::CheckRadioDown %W } bind Radiobutton <ButtonRelease-1> { - tkButtonUp %W + tk::ButtonUp %W } bind Radiobutton <Enter> { - tkCheckRadioEnter %W + tk::CheckRadioEnter %W } } -if {[string match "unix" $tcl_platform(platform)]} { +if {[string equal "x11" [tk windowingsystem]]} { bind Checkbutton <Return> { if {!$tk_strictMotif} { - tkCheckRadioInvoke %W + tk::CheckRadioInvoke %W } } bind Radiobutton <Return> { if {!$tk_strictMotif} { - tkCheckRadioInvoke %W + tk::CheckRadioInvoke %W } } bind Checkbutton <1> { - tkCheckRadioInvoke %W + tk::CheckRadioInvoke %W } bind Radiobutton <1> { - tkCheckRadioInvoke %W + tk::CheckRadioInvoke %W } bind Checkbutton <Enter> { - tkButtonEnter %W + tk::ButtonEnter %W } bind Radiobutton <Enter> { - tkButtonEnter %W + tk::ButtonEnter %W } } bind Button <space> { - tkButtonInvoke %W + tk::ButtonInvoke %W } bind Checkbutton <space> { - tkCheckRadioInvoke %W + tk::CheckRadioInvoke %W } bind Radiobutton <space> { - tkCheckRadioInvoke %W + tk::CheckRadioInvoke %W } bind Button <FocusIn> {} bind Button <Enter> { - tkButtonEnter %W + tk::ButtonEnter %W } bind Button <Leave> { - tkButtonLeave %W + tk::ButtonLeave %W } bind Button <1> { - tkButtonDown %W + tk::ButtonDown %W } bind Button <ButtonRelease-1> { - tkButtonUp %W + tk::ButtonUp %W } bind Checkbutton <FocusIn> {} bind Checkbutton <Leave> { - tkButtonLeave %W + tk::ButtonLeave %W } bind Radiobutton <FocusIn> {} bind Radiobutton <Leave> { - tkButtonLeave %W + tk::ButtonLeave %W } -if {[string match "windows" $tcl_platform(platform)]} { +if {[string equal "windows" $tcl_platform(platform)]} { ######################### # Windows implementation ######################### -# tkButtonEnter -- +# ::tk::ButtonEnter -- # The procedure below is invoked when the mouse pointer enters a # button widget. It records the button we're in and changes the # state of the button to active unless the button is disabled. @@ -140,55 +142,54 @@ if {[string match "windows" $tcl_platform(platform)]} { # Arguments: # w - The name of the widget. -proc tkButtonEnter w { - global tkPriv - if {[string compare [$w cget -state] "disabled"] \ - && [string equal $tkPriv(buttonWindow) $w]} { - $w configure -state active -relief sunken +proc ::tk::ButtonEnter w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + + # If the mouse button is down, set the relief to sunken on entry. + # Overwise, if there's an -overrelief value, set the relief to that. + + set Priv($w,relief) [$w cget -relief] + if {$Priv(buttonWindow) eq $w} { + $w configure -relief sunken -state active + set Priv($w,prelief) sunken + } elseif {[set over [$w cget -overrelief]] ne ""} { + $w configure -relief $over + set Priv($w,prelief) $over + } } - set tkPriv(window) $w + set Priv(window) $w } -# tkButtonLeave -- +# ::tk::ButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to -# inactive. If we're leaving the button window with a mouse button -# pressed (tkPriv(buttonWindow) == $w), restore the relief of the -# button too. +# button widget. It changes the state of the button back to inactive. +# Restore any modified relief too. # # Arguments: # w - The name of the widget. -proc tkButtonLeave w { - global tkPriv - if {[string compare [$w cget -state] "disabled"]} { +proc ::tk::ButtonLeave w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { $w configure -state normal } - if {[string equal $tkPriv(buttonWindow) $w]} { - $w configure -relief $tkPriv(relief) - } - set tkPriv(window) "" -} -# tkCheckRadioEnter -- -# The procedure below is invoked when the mouse pointer enters a -# checkbutton or radiobutton widget. It records the button we're in -# and changes the state of the button to active unless the button is -# disabled. -# -# Arguments: -# w - The name of the widget. + # Restore the original button relief if it was changed by Tk. + # That is signaled by the existence of Priv($w,prelief). -proc tkCheckRadioEnter w { - global tkPriv - if {[string compare [$w cget -state] "disabled"] \ - && [string equal $tkPriv(buttonWindow) $w]} { - $w configure -state active + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) } - set tkPriv(window) $w + + set Priv(window) "" } -# tkButtonDown -- +# ::tk::ButtonDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes @@ -197,63 +198,124 @@ proc tkCheckRadioEnter w { # Arguments: # w - The name of the widget. -proc tkButtonDown w { - global tkPriv - set tkPriv(relief) [$w cget -relief] - if {[string compare [$w cget -state] "disabled"]} { - set tkPriv(buttonWindow) $w +proc ::tk::ButtonDown w { + variable ::tk::Priv + + # Only save the button's relief if it does not yet exist. If there + # is an overrelief setting, Priv($w,relief) will already have been set, + # and the current value of the -relief option will be incorrect. + + if {![info exists Priv($w,relief)]} { + set Priv($w,relief) [$w cget -relief] + } + + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w $w configure -relief sunken -state active + set Priv($w,prelief) sunken + + # If this button has a repeatdelay set up, get it going with an after + after cancel $Priv(afterId) + set delay [$w cget -repeatdelay] + set Priv(repeated) 0 + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } } } -# tkCheckRadioDown -- -# The procedure below is invoked when the mouse button is pressed in -# a button widget. It records the fact that the mouse is in the button, -# saves the button's relief so it can be restored later, and changes -# the relief to sunken. +# ::tk::ButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. # # Arguments: # w - The name of the widget. -proc tkCheckRadioDown w { - global tkPriv - set tkPriv(relief) [$w cget -relief] - if {[string compare [$w cget -state] "disabled"]} { - set tkPriv(buttonWindow) $w - $w configure -state active +proc ::tk::ButtonUp w { + variable ::tk::Priv + if {$Priv(buttonWindow) eq $w} { + set Priv(buttonWindow) "" + + # Restore the button's relief if it was cached. + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + # Clean up the after event from the auto-repeater + after cancel $Priv(afterId) + + if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { + $w configure -state normal + + # Only invoke the command if it wasn't already invoked by the + # auto-repeater functionality + if { $Priv(repeated) == 0 } { + uplevel #0 [list $w invoke] + } + } } } -# tkButtonUp -- -# The procedure below is invoked when the mouse button is released -# in a button widget. It restores the button's relief and invokes -# the command as long as the mouse hasn't left the button. +# ::tk::CheckRadioEnter -- +# The procedure below is invoked when the mouse pointer enters a +# checkbutton or radiobutton widget. It records the button we're in +# and changes the state of the button to active unless the button is +# disabled. # # Arguments: # w - The name of the widget. -proc tkButtonUp w { - global tkPriv - if {[string equal $tkPriv(buttonWindow) $w]} { - set tkPriv(buttonWindow) "" - $w configure -relief $tkPriv(relief) - if {[string equal $tkPriv(window) $w] - && [string compare [$w cget -state] "disabled"]} { - $w configure -state normal - uplevel #0 [list $w invoke] +proc ::tk::CheckRadioEnter w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + if {$Priv(buttonWindow) eq $w} { + $w configure -state active + } + if {[set over [$w cget -overrelief]] ne ""} { + set Priv($w,relief) [$w cget -relief] + set Priv($w,prelief) $over + $w configure -relief $over } } + set Priv(window) $w +} + +# ::tk::CheckRadioDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckRadioDown w { + variable ::tk::Priv + if {![info exists Priv($w,relief)]} { + set Priv($w,relief) [$w cget -relief] + } + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w + set Priv(repeated) 0 + $w configure -state active + } } } -if {[string match "unix" $tcl_platform(platform)]} { +if {[string equal "x11" [tk windowingsystem]]} { ##################### # Unix implementation ##################### -# tkButtonEnter -- +# ::tk::ButtonEnter -- # The procedure below is invoked when the mouse pointer enters a # button widget. It records the button we're in and changes the # state of the button to active unless the button is disabled. @@ -261,39 +323,56 @@ if {[string match "unix" $tcl_platform(platform)]} { # Arguments: # w - The name of the widget. -proc tkButtonEnter {w} { - global tkPriv - if {[string compare [$w cget -state] "disabled"]} { +proc ::tk::ButtonEnter {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + # On unix the state is active just with mouse-over $w configure -state active - if {[string equal $tkPriv(buttonWindow) $w]} { - $w configure -state active -relief sunken + + # If the mouse button is down, set the relief to sunken on entry. + # Overwise, if there's an -overrelief value, set the relief to that. + + set Priv($w,relief) [$w cget -relief] + if {$Priv(buttonWindow) eq $w} { + $w configure -relief sunken + set Priv($w,prelief) sunken + } elseif {[set over [$w cget -overrelief]] ne ""} { + $w configure -relief $over + set Priv($w,prelief) $over } } - set tkPriv(window) $w + set Priv(window) $w } -# tkButtonLeave -- +# ::tk::ButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a -# button widget. It changes the state of the button back to -# inactive. If we're leaving the button window with a mouse button -# pressed (tkPriv(buttonWindow) == $w), restore the relief of the -# button too. +# button widget. It changes the state of the button back to inactive. +# Restore any modified relief too. # # Arguments: # w - The name of the widget. -proc tkButtonLeave w { - global tkPriv - if {[string compare [$w cget -state] "disabled"]} { +proc ::tk::ButtonLeave w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { $w configure -state normal } - if {[string equal $tkPriv(buttonWindow) $w]} { - $w configure -relief $tkPriv(relief) + + # Restore the original button relief if it was changed by Tk. + # That is signaled by the existence of Priv($w,prelief). + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) } - set tkPriv(window) "" + + set Priv(window) "" } -# tkButtonDown -- +# ::tk::ButtonDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes @@ -302,16 +381,33 @@ proc tkButtonLeave w { # Arguments: # w - The name of the widget. -proc tkButtonDown w { - global tkPriv - set tkPriv(relief) [$w cget -relief] - if {[string compare [$w cget -state] "disabled"]} { - set tkPriv(buttonWindow) $w +proc ::tk::ButtonDown w { + variable ::tk::Priv + + # Only save the button's relief if it does not yet exist. If there + # is an overrelief setting, Priv($w,relief) will already have been set, + # and the current value of the -relief option will be incorrect. + + if {![info exists Priv($w,relief)]} { + set Priv($w,relief) [$w cget -relief] + } + + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w $w configure -relief sunken + set Priv($w,prelief) sunken + + # If this button has a repeatdelay set up, get it going with an after + after cancel $Priv(afterId) + set delay [$w cget -repeatdelay] + set Priv(repeated) 0 + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } } } -# tkButtonUp -- +# ::tk::ButtonUp -- # The procedure below is invoked when the mouse button is released # in a button widget. It restores the button's relief and invokes # the command as long as the mouse hasn't left the button. @@ -319,27 +415,44 @@ proc tkButtonDown w { # Arguments: # w - The name of the widget. -proc tkButtonUp w { - global tkPriv - if {[string equal $w $tkPriv(buttonWindow)]} { - set tkPriv(buttonWindow) "" - $w configure -relief $tkPriv(relief) - if {[string equal $w $tkPriv(window)] \ - && [string compare [$w cget -state] "disabled"]} { - uplevel #0 [list $w invoke] +proc ::tk::ButtonUp w { + variable ::tk::Priv + if {[string equal $w $Priv(buttonWindow)]} { + set Priv(buttonWindow) "" + + # Restore the button's relief if it was cached. + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + # Clean up the after event from the auto-repeater + after cancel $Priv(afterId) + + if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { + # Only invoke the command if it wasn't already invoked by the + # auto-repeater functionality + if { $Priv(repeated) == 0 } { + uplevel #0 [list $w invoke] + } } } } } -if {[string match "macintosh" $tcl_platform(platform)]} { +if {[string equal [tk windowingsystem] "classic"] + || [string equal [tk windowingsystem] "aqua"]} { #################### # Mac implementation #################### -# tkButtonEnter -- +# ::tk::ButtonEnter -- # The procedure below is invoked when the mouse pointer enters a # button widget. It records the button we're in and changes the # state of the button to active unless the button is disabled. @@ -347,35 +460,54 @@ if {[string match "macintosh" $tcl_platform(platform)]} { # Arguments: # w - The name of the widget. -proc tkButtonEnter {w} { - global tkPriv - if {[string compare [$w cget -state] "disabled"]} { - if {[string equal $w $tkPriv(buttonWindow)]} { +proc ::tk::ButtonEnter {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + + # If there's an -overrelief value, set the relief to that. + + if {$Priv(buttonWindow) eq $w} { $w configure -state active + } elseif {[set over [$w cget -overrelief]] ne ""} { + set Priv($w,relief) [$w cget -relief] + set Priv($w,prelief) $over + $w configure -relief $over } } - set tkPriv(window) $w + set Priv(window) $w } -# tkButtonLeave -- +# ::tk::ButtonLeave -- # The procedure below is invoked when the mouse pointer leaves a # button widget. It changes the state of the button back to # inactive. If we're leaving the button window with a mouse button -# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# pressed (Priv(buttonWindow) == $w), restore the relief of the # button too. # # Arguments: # w - The name of the widget. -proc tkButtonLeave w { - global tkPriv - if {[string equal $w $tkPriv(buttonWindow)]} { +proc ::tk::ButtonLeave w { + variable ::tk::Priv + if {$w eq $Priv(buttonWindow)} { $w configure -state normal } - set tkPriv(window) "" + + # Restore the original button relief if it was changed by Tk. + # That is signaled by the existence of Priv($w,prelief). + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + set Priv(window) "" } -# tkButtonDown -- +# ::tk::ButtonDown -- # The procedure below is invoked when the mouse button is pressed in # a button widget. It records the fact that the mouse is in the button, # saves the button's relief so it can be restored later, and changes @@ -384,15 +516,25 @@ proc tkButtonLeave w { # Arguments: # w - The name of the widget. -proc tkButtonDown w { - global tkPriv - if {[string compare [$w cget -state] "disabled"]} { - set tkPriv(buttonWindow) $w +proc ::tk::ButtonDown w { + variable ::tk::Priv + + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w $w configure -state active + + # If this button has a repeatdelay set up, get it going with an after + after cancel $Priv(afterId) + set Priv(repeated) 0 + if { ![catch {$w cget -repeatdelay} delay] } { + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } + } } } -# tkButtonUp -- +# ::tk::ButtonUp -- # The procedure below is invoked when the mouse button is released # in a button widget. It restores the button's relief and invokes # the command as long as the mouse hasn't left the button. @@ -400,14 +542,31 @@ proc tkButtonDown w { # Arguments: # w - The name of the widget. -proc tkButtonUp w { - global tkPriv - if {[string equal $w $tkPriv(buttonWindow)]} { +proc ::tk::ButtonUp w { + variable ::tk::Priv + if {$Priv(buttonWindow) eq $w} { + set Priv(buttonWindow) "" $w configure -state normal - set tkPriv(buttonWindow) "" - if {[string equal $w $tkPriv(window)] - && [string compare [$w cget -state] "disabled"]} { - uplevel #0 [list $w invoke] + + # Restore the button's relief if it was cached. + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + # Clean up the after event from the auto-repeater + after cancel $Priv(afterId) + + if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { + # Only invoke the command if it wasn't already invoked by the + # auto-repeater functionality + if { $Priv(repeated) == 0 } { + uplevel #0 [list $w invoke] + } } } } @@ -418,15 +577,15 @@ proc tkButtonUp w { # Shared routines ################## -# tkButtonInvoke -- +# ::tk::ButtonInvoke -- # The procedure below is called when a button is invoked through # the keyboard. It simulate a press of the button via the mouse. # # Arguments: # w - The name of the widget. -proc tkButtonInvoke w { - if {[string compare [$w cget -state] "disabled"]} { +proc ::tk::ButtonInvoke w { + if {[$w cget -state] ne "disabled"} { set oldRelief [$w cget -relief] set oldState [$w cget -state] $w configure -state active -relief sunken @@ -437,7 +596,33 @@ proc tkButtonInvoke w { } } -# tkCheckRadioInvoke -- +# ::tk::ButtonAutoInvoke -- +# +# Invoke an auto-repeating button, and set it up to continue to repeat. +# +# Arguments: +# w button to invoke. +# +# Results: +# None. +# +# Side effects: +# May create an after event to call ::tk::ButtonAutoInvoke. + +proc ::tk::ButtonAutoInvoke {w} { + variable ::tk::Priv + after cancel $Priv(afterId) + set delay [$w cget -repeatinterval] + if {$Priv(window) eq $w} { + incr Priv(repeated) + uplevel #0 [list $w invoke] + } + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } +} + +# ::tk::CheckRadioInvoke -- # The procedure below is invoked when the mouse button is pressed in # a checkbutton or radiobutton widget, or when the widget is invoked # through the keyboard. It invokes the widget if it @@ -447,10 +632,8 @@ proc tkButtonInvoke w { # w - The name of the widget. # cmd - The subcommand to invoke (one of invoke, select, or deselect). -proc tkCheckRadioInvoke {w {cmd invoke}} { - if {[string compare [$w cget -state] "disabled"]} { +proc ::tk::CheckRadioInvoke {w {cmd invoke}} { + if {[$w cget -state] ne "disabled"} { uplevel #0 [list $w $cmd] } } - - |