Commit | Line | Data |
---|---|---|
86530b38 AT |
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 |