Initial revision

1 files changed, 456 insertions, 0 deletions

diff --git a/library/button.tcl b/library/button.tcl
new file mode 100644
index 0000000..b017b80
--- /dev/null
+++ b/library/button.tcl
@@ -0,0 +1,456 @@
+# 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.
+#
+# SCCS: @(#) button.tcl 1.22 96/11/14 14:49:11
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994-1996 Sun Microsystems, Inc.
+#
+# 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 {$tcl_platform(platform) == "macintosh"} {
+    bind Radiobutton <Enter> {
+	tkButtonEnter %W
+    }
+    bind Radiobutton <1> {
+	tkButtonDown %W
+    }
+    bind Radiobutton <ButtonRelease-1> {
+	tkButtonUp %W
+    }
+    bind Checkbutton <Enter> {
+	tkButtonEnter %W
+    }
+    bind Checkbutton <1> {
+	tkButtonDown %W
+    }
+    bind Checkbutton <ButtonRelease-1> {
+	tkButtonUp %W
+    }
+}
+if {$tcl_platform(platform) == "windows"} {
+    bind Checkbutton <equal> {
+	tkCheckRadioInvoke %W select
+    }
+    bind Checkbutton <plus> {
+	tkCheckRadioInvoke %W select
+    }
+    bind Checkbutton <minus> {
+	tkCheckRadioInvoke %W deselect
+    }
+    bind Checkbutton <1> {
+	tkCheckRadioDown %W
+    }
+    bind Checkbutton <ButtonRelease-1> {
+	tkButtonUp %W
+    }
+    bind Checkbutton <Enter> {
+	tkCheckRadioEnter %W
+    }
+
+    bind Radiobutton <1> {
+	tkCheckRadioDown %W
+    }
+    bind Radiobutton <ButtonRelease-1> {
+	tkButtonUp %W
+    }
+    bind Radiobutton <Enter> {
+	tkCheckRadioEnter %W
+    }
+}
+if {$tcl_platform(platform) == "unix"} {
+    bind Checkbutton <Return> {
+	if !$tk_strictMotif {
+	    tkCheckRadioInvoke %W
+	}
+    }
+    bind Radiobutton <Return> {
+	if !$tk_strictMotif {
+	    tkCheckRadioInvoke %W
+	}
+    }
+    bind Checkbutton <1> {
+	tkCheckRadioInvoke %W
+    }
+    bind Radiobutton <1> {
+	tkCheckRadioInvoke %W
+    }
+    bind Checkbutton <Enter> {
+	tkButtonEnter %W
+    }
+    bind Radiobutton <Enter> {
+	tkButtonEnter %W
+    }
+}
+
+bind Button <space> {
+    tkButtonInvoke %W
+}
+bind Checkbutton <space> {
+    tkCheckRadioInvoke %W
+}
+bind Radiobutton <space> {
+    tkCheckRadioInvoke %W
+}
+
+bind Button <FocusIn> {}
+bind Button <Enter> {
+    tkButtonEnter %W
+}
+bind Button <Leave> {
+    tkButtonLeave %W
+}
+bind Button <1> {
+    tkButtonDown %W
+}
+bind Button <ButtonRelease-1> {
+    tkButtonUp %W
+}
+
+bind Checkbutton <FocusIn> {}
+bind Checkbutton <Leave> {
+    tkButtonLeave %W
+}
+
+bind Radiobutton <FocusIn> {}
+bind Radiobutton <Leave> {
+    tkButtonLeave %W
+}
+
+if {$tcl_platform(platform) == "windows"} {
+
+#########################
+# Windows implementation 
+#########################
+
+# tkButtonEnter --
+# 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 tkButtonEnter w {
+    global tkPriv
+    if {[$w cget -state] != "disabled"} {
+	if {$tkPriv(buttonWindow) == $w} {
+	    $w configure -state active -relief sunken
+	}
+    }
+    set tkPriv(window) $w
+}
+
+# tkButtonLeave --
+# 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.
+#
+# Arguments:
+# w -		The name of the widget.
+
+proc tkButtonLeave w {
+    global tkPriv
+    if {[$w cget -state] != "disabled"} {
+	$w config -state normal
+    }
+    if {$w == $tkPriv(buttonWindow)} {
+	$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.
+
+proc tkCheckRadioEnter w {
+    global tkPriv
+    if {[$w cget -state] != "disabled"} {
+	if {$tkPriv(buttonWindow) == $w} {
+	    $w configure -state active
+	}
+    }
+    set tkPriv(window) $w
+}
+
+# tkButtonDown --
+# 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 tkButtonDown w {
+    global tkPriv
+    set tkPriv(relief) [lindex [$w conf -relief] 4]
+    if {[$w cget -state] != "disabled"} {
+	set tkPriv(buttonWindow) $w
+	$w config -relief sunken -state active
+    }
+}
+
+# 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.
+#
+# Arguments:
+# w -		The name of the widget.
+
+proc tkCheckRadioDown w {
+    global tkPriv
+    set tkPriv(relief) [lindex [$w conf -relief] 4]
+    if {[$w cget -state] != "disabled"} {
+	set tkPriv(buttonWindow) $w
+	$w config -state active
+    }
+}
+
+# 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.
+#
+# Arguments:
+# w -		The name of the widget.
+
+proc tkButtonUp w {
+    global tkPriv
+    if {$w == $tkPriv(buttonWindow)} {
+	set tkPriv(buttonWindow) ""
+	if {($w == $tkPriv(window))
+		&& ([$w cget -state] != "disabled")} {
+	    $w config -relief $tkPriv(relief) -state normal
+	    uplevel #0 [list $w invoke]
+	}
+    }
+}
+
+}
+
+if {$tcl_platform(platform) == "unix"} {
+
+#####################
+# Unix implementation
+#####################
+
+# tkButtonEnter --
+# 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 tkButtonEnter {w} {
+    global tkPriv
+    if {[$w cget -state] != "disabled"} {
+	$w config -state active
+	if {$tkPriv(buttonWindow) == $w} {
+	    $w configure -state active -relief sunken
+	}
+    }
+    set tkPriv(window) $w
+}
+
+# tkButtonLeave --
+# 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.
+#
+# Arguments:
+# w -		The name of the widget.
+
+proc tkButtonLeave w {
+    global tkPriv
+    if {[$w cget -state] != "disabled"} {
+	$w config -state normal
+    }
+    if {$w == $tkPriv(buttonWindow)} {
+	$w configure -relief $tkPriv(relief)
+    }
+    set tkPriv(window) ""
+}
+
+# tkButtonDown --
+# 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 tkButtonDown w {
+    global tkPriv
+    set tkPriv(relief) [lindex [$w config -relief] 4]
+    if {[$w cget -state] != "disabled"} {
+	set tkPriv(buttonWindow) $w
+	$w config -relief sunken
+    }
+}
+
+# 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.
+#
+# Arguments:
+# w -		The name of the widget.
+
+proc tkButtonUp w {
+    global tkPriv
+    if {$w == $tkPriv(buttonWindow)} {
+	set tkPriv(buttonWindow) ""
+	$w config -relief $tkPriv(relief)
+	if {($w == $tkPriv(window))
+		&& ([$w cget -state] != "disabled")} {
+	    uplevel #0 [list $w invoke]
+	}
+    }
+}
+
+}
+
+if {$tcl_platform(platform) == "macintosh"} {
+
+####################
+# Mac implementation
+####################
+
+# tkButtonEnter --
+# 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 tkButtonEnter {w} {
+    global tkPriv
+    if {[$w cget -state] != "disabled"} {
+	if {$tkPriv(buttonWindow) == $w} {
+	    $w configure -state active
+	}
+    }
+    set tkPriv(window) $w
+}
+
+# tkButtonLeave --
+# 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.
+#
+# Arguments:
+# w -		The name of the widget.
+
+proc tkButtonLeave w {
+    global tkPriv
+    if {$w == $tkPriv(buttonWindow)} {
+	$w configure -state normal
+    }
+    set tkPriv(window) ""
+}
+
+# tkButtonDown --
+# 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 tkButtonDown w {
+    global tkPriv
+    if {[$w cget -state] != "disabled"} {
+	set tkPriv(buttonWindow) $w
+	$w config -state active
+    }
+}
+
+# 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.
+#
+# Arguments:
+# w -		The name of the widget.
+
+proc tkButtonUp w {
+    global tkPriv
+    if {$w == $tkPriv(buttonWindow)} {
+	$w config -state normal
+	set tkPriv(buttonWindow) ""
+	if {($w == $tkPriv(window))
+		&& ([$w cget -state] != "disabled")} {
+	    uplevel #0 [list $w invoke]
+	}
+    }
+}
+
+}
+
+##################
+# Shared routines
+##################
+
+# tkButtonInvoke --
+# 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 {[$w cget -state] != "disabled"} {
+	set oldRelief [$w cget -relief]
+	set oldState [$w cget -state]
+	$w configure -state active -relief sunken
+	update idletasks
+	after 100
+	$w configure -state $oldState -relief $oldRelief
+	uplevel #0 [list $w invoke]
+    }
+}
+
+# tkCheckRadioInvoke --
+# 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 tkCheckRadioInvoke {w {cmd invoke}} {
+    if {[$w cget -state] != "disabled"} {
+	uplevel #0 [list $w $cmd]
+    }
+}
+