diff options
Diffstat (limited to 'Master/tlpkg/tlperl.old/lib/Tk/Button.pm')
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/Button.pm | 148 |
1 files changed, 0 insertions, 148 deletions
diff --git a/Master/tlpkg/tlperl.old/lib/Tk/Button.pm b/Master/tlpkg/tlperl.old/lib/Tk/Button.pm deleted file mode 100644 index efa597dee14..00000000000 --- a/Master/tlpkg/tlperl.old/lib/Tk/Button.pm +++ /dev/null @@ -1,148 +0,0 @@ -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.008'; # $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 $relief); - -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') - { - $w->configure('-state' => 'active'); - $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow) - } - $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'); - $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow); - 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; - $relief = $w->cget('-relief'); - if ($w->cget('-state') ne 'disabled') - { - $buttonWindow = $w; - $w->configure('-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. -sub butUp -{ - my $w = shift; - if (defined($buttonWindow) && $buttonWindow == $w) - { - undef $buttonWindow; - $w->configure('-relief' => $relief); - if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled') - { - $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; - } -} - - - -1; - -__END__ - - - - - |