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-1998 Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or

use vars qw($VERSION @ISA);
$VERSION = '3.007'; # $Id: //depot/Tk8/Tk/Button.pm#7$

# modify it under the same terms as Perl itself, subject 
# to additional disclaimer in license.terms due to partial
# derivation from Tk4.0 sources.
#
#	WARNING:  MODIFIED 7/3/97 BY JIM TURNER (JWT) OF LOCKHEED MARTIN TO CAUSE
#	UNDERLINED-CHARACTERS IN BUTTONS TO BE BOUND TO THE BUTTON'S TOP-LEVEL
#	WIDGET AS "<ALT-key>" SO THAT ALT-SEQUENCE ACTUALLY INVOKES BUTTON!
#	ALSO MAKE -TEXT OPTION SUPPORT "~" (ie. "te~xt" same as -underline=>2)!
#

use strict;
####JWT:  use AutoLoader;

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');  #Added JWT: makes <cr> invoke button!
 return $class;
}

sub InitObject    #ADDED 7/3/97 BY JWT TO CREATE ALT-KEY BINDINGS IN TOPLEVEL 
{                 #FOR UNDERLINED CHARACTERS IN BUTTONS!
	my ($w,$args) = @_;

	my ($ul);

	$w->SUPER::InitObject($args);

	my ($mytext) = $args->{'-text'};

	if (defined($mytext))  #ONLY BOTHER IF -TEXT OPTION DEFINED!
	{
		if (defined($args->{'-underline'}))  #USE -UNDERLINE VALUE.
		{
			$ul = $args->{'-underline'};
			$ul = undef  if ($ul < 0 || $ul > length($mytext));
		}
		else   #NO -UNDERLINE, SEE IF THERE'S A "~" IN -TEXT!
		{
			$ul = ($mytext =~ s/^(.*)~(.+)$/$1$2/) ? length($1): undef;
			if (defined($ul))   #THERE IS A "~" SET UNDERLINE TO NEXT CHAR.
			{
				$args->{'-underline'} = $ul;
				$args->{'-text'} = $mytext;   #STRIP "~" FROM -TEXT.
			}
		}
		if (defined($ul))  #BIND ALT-CHAR TO INVOKE BUTTON IF UNDERLINE OR "~".
		{
			$ul = substr($mytext,$ul,1);  #CONVERT CHAR. POSN TO ACTUAL CHAR.
			$w->toplevel->bind("<Alt-\l$ul>", [$w => "Invoke"]);
		}
	}
}

# 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__