| 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-1999 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 = '3.014'; # $Id: //depot/Tk8/Tk/Button.pm#14 $ |
| 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 | |