home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Button.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  3.4 KB  |  141 lines
  1. # Conversion from Tk4.0 button.tcl competed.
  2. #
  3. # Copyright (c) 1992-1994 The Regents of the University of California.
  4. # Copyright (c) 1994 Sun Microsystems, Inc.
  5. # Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  6. # This program is free software; you can redistribute it and/or
  7. # modify it under the same terms as Perl itself, subject 
  8. # to additional disclaimer in license.terms due to partial
  9. # derivation from Tk4.0 sources.
  10.  
  11. package Tk::Button;  
  12. use AutoLoader;
  13. @ISA = qw(Tk::Widget);
  14.  
  15. use strict;
  16. use vars qw($buttonWindow $relief);
  17.  
  18. sub Tk_cmd { \&Tk::button }
  19.  
  20. Construct Tk::Widget 'Button';
  21.  
  22. sub ClassInit
  23. {
  24.  my ($class,$mw) = @_;
  25.  $mw->bind($class,'<Enter>', 'Enter');
  26.  $mw->bind($class,'<Leave>', 'Leave');
  27.  $mw->bind($class,'<1>', 'butDown');
  28.  $mw->bind($class,'<ButtonRelease-1>', 'butUp');
  29.  $mw->bind($class,'<space>', 'Invoke');
  30.  return $class;
  31. }
  32.  
  33. # tkButtonEnter --
  34. # The procedure below is invoked when the mouse pointer enters a
  35. # button widget.  It records the button we're in and changes the
  36. # state of the button to active unless the button is disabled.
  37. #
  38. # Arguments:
  39. # w -        The name of the widget.
  40.  
  41. sub Enter
  42. {
  43.  my $w = shift;
  44.  my $E = shift;
  45.  if ($w->cget("-state") ne "disabled")
  46.   {
  47.    $w->configure("-state" => "active");
  48.    $w->configure("-state" => "active", "-relief" => "sunken") if (defined($buttonWindow) && $w == $buttonWindow)
  49.   }
  50.  $Tk::window = $w;
  51. }
  52.  
  53. # tkButtonLeave --
  54. # The procedure below is invoked when the mouse pointer leaves a
  55. # button widget.  It changes the state of the button back to
  56. # inactive.  If we're leaving the button window with a mouse button
  57. # pressed (tkPriv(buttonWindow) == $w), restore the relief of the
  58. # button too.
  59. #
  60. # Arguments:
  61. # w -        The name of the widget.
  62. sub Leave
  63. {
  64.  my $w = shift;
  65.  $w->configure("-state"=>"normal") if ($w->cget("-state") ne "disabled");
  66.  $w->configure("-relief" => $relief) if (defined($buttonWindow) && $w == $buttonWindow);
  67.  undef $Tk::window;
  68. }
  69.  
  70. # tkButtonDown --
  71. # The procedure below is invoked when the mouse button is pressed in
  72. # a button widget.  It records the fact that the mouse is in the button,
  73. # saves the button's relief so it can be restored later, and changes
  74. # the relief to sunken.
  75. #
  76. # Arguments:
  77. # w -        The name of the widget.
  78. sub butDown
  79. {
  80.  my $w = shift;
  81.  $relief = $w->cget("-relief");
  82.  if ($w->cget("-state") ne "disabled")
  83.   {
  84.    $buttonWindow = $w;
  85.    $w->configure("-relief" => "sunken")
  86.   }
  87. }
  88.  
  89. # tkButtonUp --
  90. # The procedure below is invoked when the mouse button is released
  91. # in a button widget.  It restores the button's relief and invokes
  92. # the command as long as the mouse hasn't left the button.
  93. #
  94. # Arguments:
  95. # w -        The name of the widget.
  96. sub butUp
  97. {
  98.  my $w = shift;
  99.  if (defined($buttonWindow) && $buttonWindow == $w)
  100.   {
  101.    undef $buttonWindow;
  102.    $w->configure("-relief" => $relief);
  103.    if ($w->IS($Tk::window) && $w->cget("-state") ne "disabled")
  104.     {
  105.      $w->invoke;
  106.     }
  107.   }
  108. }
  109.  
  110. # tkButtonInvoke --
  111. # The procedure below is called when a button is invoked through
  112. # the keyboard.  It simulate a press of the button via the mouse.
  113. #
  114. # Arguments:
  115. # w -        The name of the widget.
  116. sub Invoke 
  117. {
  118.  my $w = shift;
  119.  if ($w->cget("-state") ne "disabled")
  120.   {
  121.    my $oldRelief = $w->cget("-relief");
  122.    my $oldState  = $w->cget("-state");
  123.    $w->configure("-state" => "active", "-relief" => "sunken");
  124.    $w->idletasks;
  125.    $w->after(100);
  126.    $w->configure("-state" => $oldState, "-relief" => $oldRelief);
  127.    $w->invoke;
  128.   }
  129. }
  130.  
  131.  
  132.  
  133. 1;
  134.  
  135. __END__
  136.  
  137.  
  138.  
  139.  
  140.  
  141.