This repository has been archived on 2024-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
BiblioMxWeb/windowsAgent/dist/tk/button.tcl
2021-06-17 01:30:13 +02:00

779 lines
20 KiB
Tcl
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

# button.tcl --
#
# This file defines the default bindings for Tk label, button,
# checkbutton, and radiobutton widgets and provides procedures
# that help in implementing those bindings.
#
# 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.
#
#-------------------------------------------------------------------------
# The code below creates the default class bindings for buttons.
#-------------------------------------------------------------------------
if {[tk windowingsystem] eq "aqua"} {
bind Radiobutton <Enter> {
tk::ButtonEnter %W
}
bind Radiobutton <1> {
tk::ButtonDown %W
}
bind Radiobutton <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Checkbutton <Enter> {
tk::ButtonEnter %W
}
bind Checkbutton <1> {
tk::ButtonDown %W
}
bind Checkbutton <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Checkbutton <Leave> {
tk::ButtonLeave %W
}
}
if {"win32" eq [tk windowingsystem]} {
bind Checkbutton <equal> {
tk::CheckRadioInvoke %W select
}
bind Checkbutton <plus> {
tk::CheckRadioInvoke %W select
}
bind Checkbutton <minus> {
tk::CheckRadioInvoke %W deselect
}
bind Checkbutton <1> {
tk::CheckRadioDown %W
}
bind Checkbutton <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Checkbutton <Enter> {
tk::CheckRadioEnter %W
}
bind Checkbutton <Leave> {
tk::ButtonLeave %W
}
bind Radiobutton <1> {
tk::CheckRadioDown %W
}
bind Radiobutton <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Radiobutton <Enter> {
tk::CheckRadioEnter %W
}
}
if {"x11" eq [tk windowingsystem]} {
bind Checkbutton <Return> {
if {!$tk_strictMotif} {
tk::CheckInvoke %W
}
}
bind Radiobutton <Return> {
if {!$tk_strictMotif} {
tk::CheckRadioInvoke %W
}
}
bind Checkbutton <1> {
tk::CheckInvoke %W
}
bind Radiobutton <1> {
tk::CheckRadioInvoke %W
}
bind Checkbutton <Enter> {
tk::CheckEnter %W
}
bind Radiobutton <Enter> {
tk::ButtonEnter %W
}
bind Checkbutton <Leave> {
tk::CheckLeave %W
}
}
bind Button <space> {
tk::ButtonInvoke %W
}
bind Checkbutton <space> {
tk::CheckRadioInvoke %W
}
bind Radiobutton <space> {
tk::CheckRadioInvoke %W
}
bind Button <<Invoke>> {
tk::ButtonInvoke %W
}
bind Checkbutton <<Invoke>> {
tk::CheckRadioInvoke %W
}
bind Radiobutton <<Invoke>> {
tk::CheckRadioInvoke %W
}
bind Button <FocusIn> {}
bind Button <Enter> {
tk::ButtonEnter %W
}
bind Button <Leave> {
tk::ButtonLeave %W
}
bind Button <1> {
tk::ButtonDown %W
}
bind Button <ButtonRelease-1> {
tk::ButtonUp %W
}
bind Checkbutton <FocusIn> {}
bind Radiobutton <FocusIn> {}
bind Radiobutton <Leave> {
tk::ButtonLeave %W
}
if {"win32" eq [tk windowingsystem]} {
#########################
# Windows implementation
#########################
# ::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.
#
# Arguments:
# w - The name of the widget.
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 Priv(window) $w
}
# ::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.
# Restore any modified relief too.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonLeave w {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
$w configure -state normal
}
# 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) ""
}
# ::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
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
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]]
}
}
}
# ::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 ::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]
}
}
}
}
# ::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 ::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 {"x11" eq [tk windowingsystem]} {
#####################
# Unix implementation
#####################
# ::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.
#
# Arguments:
# w - The name of the widget.
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 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 Priv(window) $w
}
# ::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.
# Restore any modified relief too.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonLeave w {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
$w configure -state normal
}
# 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) ""
}
# ::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
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
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]]
}
}
}
# ::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 ::tk::ButtonUp w {
variable ::tk::Priv
if {$w eq $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 {[tk windowingsystem] eq "aqua"} {
####################
# Mac implementation
####################
# ::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.
#
# Arguments:
# w - The name of the widget.
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 Priv(window) $w
}
# ::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 (Priv(buttonWindow) == $w), restore the relief of the
# button too.
#
# Arguments:
# w - The name of the widget.
proc ::tk::ButtonLeave w {
variable ::tk::Priv
if {$w eq $Priv(buttonWindow)} {
$w configure -state normal
}
# 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) ""
}
# ::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
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
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]]
}
}
}
}
# ::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 ::tk::ButtonUp w {
variable ::tk::Priv
if {$Priv(buttonWindow) eq $w} {
set Priv(buttonWindow) ""
$w configure -state normal
# 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]
}
}
}
}
}
##################
# Shared routines
##################
# ::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 ::tk::ButtonInvoke w {
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
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]
}
}
# ::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
# isn't disabled.
#
# Arguments:
# w - The name of the widget.
# cmd - The subcommand to invoke (one of invoke, select, or deselect).
proc ::tk::CheckRadioInvoke {w {cmd invoke}} {
if {[$w cget -state] ne "disabled"} {
uplevel #0 [list $w $cmd]
}
}
# Special versions of the handlers for checkbuttons on Unix that do the magic
# to make things work right when the checkbutton indicator is hidden;
# radiobuttons don't need this complexity.
# ::tk::CheckInvoke --
# The procedure below invokes the checkbutton, like ButtonInvoke, but handles
# what to do when the checkbutton indicator is missing. Only used on Unix.
#
# Arguments:
# w - The name of the widget.
proc ::tk::CheckInvoke {w} {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
# Additional logic to switch the "selected" colors around if necessary
# (when we're indicator-less).
if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} {
if {[$w cget -selectcolor] eq $Priv($w,aselectcolor)} {
$w configure -selectcolor $Priv($w,selectcolor)
} else {
$w configure -selectcolor $Priv($w,aselectcolor)
}
}
uplevel #0 [list $w invoke]
}
}
# ::tk::CheckEnter --
# The procedure below enters the checkbutton, like ButtonEnter, but handles
# what to do when the checkbutton indicator is missing. Only used on Unix.
#
# Arguments:
# w - The name of the widget.
proc ::tk::CheckEnter {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 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
}
# Compute what the "selected and active" color should be.
if {![$w cget -indicatoron] && [$w cget -selectcolor] ne ""} {
set Priv($w,selectcolor) [$w cget -selectcolor]
lassign [winfo rgb $w [$w cget -selectcolor]] r1 g1 b1
lassign [winfo rgb $w [$w cget -activebackground]] r2 g2 b2
set Priv($w,aselectcolor) \
[format "#%04x%04x%04x" [expr {($r1+$r2)/2}] \
[expr {($g1+$g2)/2}] [expr {($b1+$b2)/2}]]
# use uplevel to work with other var resolvers
if {[uplevel #0 [list set [$w cget -variable]]]
eq [$w cget -onvalue]} {
$w configure -selectcolor $Priv($w,aselectcolor)
}
}
}
set Priv(window) $w
}
# ::tk::CheckLeave --
# The procedure below leaves the checkbutton, like ButtonLeave, but handles
# what to do when the checkbutton indicator is missing. Only used on Unix.
#
# Arguments:
# w - The name of the widget.
proc ::tk::CheckLeave {w} {
variable ::tk::Priv
if {[$w cget -state] ne "disabled"} {
$w configure -state normal
}
# Restore the original button "selected" color; assume that the user
# wasn't monkeying around with things too much.
if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} {
$w configure -selectcolor $Priv($w,selectcolor)
}
unset -nocomplain Priv($w,selectcolor) Priv($w,aselectcolor)
# 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) ""
}
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End: