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