summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Button.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Button.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Button.pm247
1 files changed, 247 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Button.pm b/Master/tlpkg/tlperl/lib/Tk/Button.pm
new file mode 100644
index 00000000000..b423f8caaa5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Button.pm
@@ -0,0 +1,247 @@
+package Tk::Button;
+# Conversion from Tk4.0 button.tcl competed.
+#
+# Copyright (c) 1992-1994 The Regents of the University of California.
+# Copyright (c) 1994 Sun Microsystems, Inc.
+# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or
+
+use vars qw($VERSION);
+$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $
+
+# modify it under the same terms as Perl itself, subject
+# to additional disclaimer in license.terms due to partial
+# derivation from Tk4.0 sources.
+
+use strict;
+
+require Tk::Widget;
+use base qw(Tk::Widget);
+
+use vars qw($buttonWindow $afterId $repeated);
+
+Tk::Methods('deselect','flash','invoke','select','toggle');
+
+sub Tk_cmd { \&Tk::button }
+
+Construct Tk::Widget 'Button';
+
+sub ClassInit
+{
+ my ($class,$mw) = @_;
+ $mw->bind($class,'<Enter>', 'Enter');
+ $mw->bind($class,'<Leave>', 'Leave');
+ $mw->bind($class,'<1>', 'butDown');
+ $mw->bind($class,'<ButtonRelease-1>', 'butUp');
+ $mw->bind($class,'<space>', 'Invoke');
+ $mw->bind($class,'<Return>', 'Invoke');
+ return $class;
+}
+
+# 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.
+
+sub Enter
+{
+ my $w = shift;
+ my $E = shift;
+ 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.
+ $w->{__relief__} = $w->cget('-relief');
+ if (defined $buttonWindow && $w == $buttonWindow)
+ {
+ $w->configure(-relief => 'sunken');
+ $w->{__prelief__} = 'sunken';
+ }
+ elsif ((my $over = $w->cget('-overrelief')) ne '')
+ {
+ $w->configure(-relief => $over);
+ $w->{__prelief__} = $over;
+ }
+ }
+ $Tk::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.
+sub Leave
+{
+ my $w = shift;
+ $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled');
+ # Restore the original button relief if it was changed by Tk.
+ # That is signaled by the existence of Priv($w,prelief).
+ if (exists $w->{__relief__})
+ {
+ if (exists $w->{__prelief__} &&
+ $w->{__prelief__} eq $w->cget('-relief'))
+ {
+ $w->configure(-relief => $w->{__relief__});
+ }
+ delete $w->{__relief__};
+ delete $w->{__prelief__};
+ }
+ undef $Tk::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.
+sub butDown
+{
+ my $w = shift;
+
+ # 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 (!exists $w->{__relief__})
+ {
+ $w->{__relief__} = $w->cget('-relief');
+ }
+
+ if ($w->cget('-state') ne 'disabled')
+ {
+ $buttonWindow = $w;
+ $w->configure('-relief' => 'sunken', '-state' => 'active');
+ $w->{__prelief__} = 'sunken';
+
+ # If this button has a repeatdelay set up, get it going with an after
+ $w->afterCancel($afterId);
+ my $delay = $w->cget('-repeatdelay');
+ $repeated = 0;
+ if ($delay > 0)
+ {
+ $afterId = $w->after($delay, [$w, 'AutoInvoke']);
+ }
+ }
+}
+
+# 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.
+sub butUp
+{
+ my $w = shift;
+ if (defined($buttonWindow) && $buttonWindow == $w)
+ {
+ undef $buttonWindow;
+
+ # Restore the button's relief if it was cached.
+ if (exists $w->{__relief__})
+ {
+ if (exists $w->{__prelief__} &&
+ $w->{__prelief__} eq $w->cget('-relief'))
+ {
+ $w->configure(-relief => $w->{__relief__});
+ }
+ delete $w->{__relief__};
+ delete $w->{__prelief__};
+ }
+
+ # Clean up the after event from the auto-repeater
+ $w->afterCancel($afterId);
+
+ if ($w->IS($Tk::window) && $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 ($repeated == 0)
+ {
+ $w->invoke;
+ }
+ }
+ }
+}
+
+# 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.
+sub Invoke
+{
+ my $w = shift;
+ if ($w->cget('-state') ne 'disabled')
+ {
+ my $oldRelief = $w->cget('-relief');
+ my $oldState = $w->cget('-state');
+ $w->configure('-state' => 'active', '-relief' => 'sunken');
+ $w->idletasks;
+ $w->after(100);
+ $w->configure('-state' => $oldState, '-relief' => $oldRelief);
+ $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.
+sub AutoInvoke
+{
+ my $w = shift;
+ $w->afterCancel($afterId);
+ my $delay = $w->cget('-repeatinterval');
+ if ($w->IS($Tk::window))
+ {
+ $repeated++;
+ $w->invoke;
+ }
+ if ($delay > 0)
+ {
+ $afterId = $w->after($delay, [$w, 'AutoInvoke']);
+ }
+}
+
+# Used for Tk::Widget::AmpWidget
+sub AmpWidgetPostHook
+{
+ my $w = shift;
+ $w->bind('<<AltUnderlined>>' => ['invoke']);
+}
+
+
+1;
+
+__END__
+
+
+
+
+