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'); $mw->bind($class,'', 'Leave'); $mw->bind($class,'<1>', 'butDown'); $mw->bind($class,'', 'butUp'); $mw->bind($class,'', 'Invoke'); $mw->bind($class,'', '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__