Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Converted from scale.tcl -- |
2 | # | |
3 | # This file defines the default bindings for Tk scale widgets. | |
4 | # | |
5 | # @(#) scale.tcl 1.3 94/12/17 16:05:23 | |
6 | # | |
7 | # Copyright (c) 1994 The Regents of the University of California. | |
8 | # Copyright (c) 1994 Sun Microsystems, Inc. | |
9 | # | |
10 | # See the file "license.terms" for information on usage and redistribution | |
11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
12 | ||
13 | package Tk::Scale; | |
14 | ||
15 | use vars qw($VERSION); | |
16 | $VERSION = '3.012'; # $Id: //depot/Tk8/Scale/Scale.pm#12 $ | |
17 | ||
18 | use Tk qw($XS_VERSION); | |
19 | use AutoLoader; | |
20 | ||
21 | use base qw(Tk::Widget); | |
22 | ||
23 | Construct Tk::Widget 'Scale'; | |
24 | ||
25 | bootstrap Tk::Scale; | |
26 | ||
27 | sub Tk_cmd { \&Tk::scale } | |
28 | ||
29 | Tk::Methods('coords','get','identify','set'); | |
30 | ||
31 | ||
32 | import Tk qw(Ev); | |
33 | ||
34 | # | |
35 | # Bind -- | |
36 | # This procedure below invoked the first time the mouse enters a | |
37 | # scale widget or a scale widget receives the input focus. It creates | |
38 | # all of the class bindings for scales. | |
39 | # | |
40 | # Arguments: | |
41 | # event - Indicates which event caused the procedure to be invoked | |
42 | # (Enter or FocusIn). It is used so that we can carry out | |
43 | # the functions of that event in addition to setting up | |
44 | # bindings. | |
45 | sub ClassInit | |
46 | { | |
47 | my ($class,$mw) = @_; | |
48 | ||
49 | $mw->bind($class,'<Enter>',['Enter',Ev('x'),Ev('y')]); | |
50 | $mw->bind($class,'<Motion>',['Activate',Ev('x'),Ev('y')]); | |
51 | $mw->bind($class,'<Leave>','Leave'); | |
52 | ||
53 | $mw->bind($class,'<1>',['ButtonDown',Ev('x'),Ev('y')]); | |
54 | $mw->bind($class,'<B1-Motion>',['Drag',Ev('x'),Ev('y')]); | |
55 | $mw->bind($class,'<B1-Leave>','NoOp'); | |
56 | $mw->bind($class,'<B1-Enter>','NoOp'); | |
57 | $mw->bind($class,'<ButtonRelease-1>',['ButtonUp',Ev('x'),Ev('y')]); | |
58 | ||
59 | $mw->bind($class,'<2>',['ButtonDown',Ev('x'),Ev('y')]); | |
60 | $mw->bind($class,'<B2-Motion>',['Drag',Ev('x'),Ev('y')]); | |
61 | $mw->bind($class,'<B2-Leave>','NoOp'); | |
62 | $mw->bind($class,'<B2-Enter>','NoOp'); | |
63 | $mw->bind($class,'<ButtonRelease-2>',['ButtonUp',Ev('x'),Ev('y')]); | |
64 | ||
65 | $mw->bind($class,'<Control-1>',['ControlPress',Ev('x'),Ev('y')]); | |
66 | ||
67 | $mw->bind($class,'<Up>',['Increment','up','little','noRepeat']); | |
68 | $mw->bind($class,'<Down>',['Increment','down','little','noRepeat']); | |
69 | $mw->bind($class,'<Left>',['Increment','up','little','noRepeat']); | |
70 | $mw->bind($class,'<Right>',['Increment','down','little','noRepeat']); | |
71 | ||
72 | $mw->bind($class,'<Control-Up>',['Increment','up','big','noRepeat']); | |
73 | $mw->bind($class,'<Control-Down>',['Increment','down','big','noRepeat']); | |
74 | $mw->bind($class,'<Control-Left>',['Increment','up','big','noRepeat']); | |
75 | $mw->bind($class,'<Control-Right>',['Increment','down','big','noRepeat']); | |
76 | ||
77 | $mw->bind($class,'<Home>',['set',Ev('cget','-from')]); | |
78 | $mw->bind($class,'<End>',['set',Ev('cget','-to')]); | |
79 | return $class; | |
80 | } | |
81 | ||
82 | 1; | |
83 | ||
84 | __END__ | |
85 | ||
86 | # Activate -- | |
87 | # This procedure is invoked to check a given x-y position in the | |
88 | # scale and activate the slider if the x-y position falls within | |
89 | # the slider. | |
90 | # | |
91 | # Arguments: | |
92 | # w - The scale widget. | |
93 | # x, y - Mouse coordinates. | |
94 | sub Activate | |
95 | { | |
96 | my $w = shift; | |
97 | my $x = shift; | |
98 | my $y = shift; | |
99 | return if ($w->cget('-state') eq 'disabled'); | |
100 | my $ident = $w->identify($x,$y); | |
101 | if (defined($ident) && $ident eq 'slider') | |
102 | { | |
103 | $w->configure(-state => 'active') | |
104 | } | |
105 | else | |
106 | { | |
107 | $w->configure(-state => 'normal') | |
108 | } | |
109 | } | |
110 | ||
111 | sub Leave | |
112 | { | |
113 | my ($w) = @_; | |
114 | $w->configure('-activebackground',$w->{'activeBg'}) if ($Tk::strictMotif); | |
115 | $w->configure('-state','normal') if ($w->cget('-state') eq 'active'); | |
116 | } | |
117 | ||
118 | sub Enter | |
119 | { | |
120 | my ($w,$x,$y) = @_; | |
121 | if ($Tk::strictMotif) | |
122 | { | |
123 | $w->{'activeBg'} = $w->cget('-activebackground'); | |
124 | $w->configure('-activebackground',$w->cget('-background')); | |
125 | } | |
126 | $w->Activate($x,$y); | |
127 | } | |
128 | ||
129 | sub ButtonUp | |
130 | { | |
131 | my ($w,$x,$y) = @_; | |
132 | $w->CancelRepeat(); | |
133 | $w->EndDrag(); | |
134 | $w->Activate($x,$y) | |
135 | } | |
136 | ||
137 | ||
138 | # ButtonDown -- | |
139 | # This procedure is invoked when a button is pressed in a scale. It | |
140 | # takes different actions depending on where the button was pressed. | |
141 | # | |
142 | # Arguments: | |
143 | # w - The scale widget. | |
144 | # x, y - Mouse coordinates of button press. | |
145 | sub ButtonDown | |
146 | { | |
147 | my $w = shift; | |
148 | my $x = shift; | |
149 | my $y = shift; | |
150 | $Tk::dragging = 0; | |
151 | $el = $w->identify($x,$y); | |
152 | return unless ($el); | |
153 | if ($el eq 'trough1') | |
154 | { | |
155 | $w->Increment('up','little','initial') | |
156 | } | |
157 | elsif ($el eq 'trough2') | |
158 | { | |
159 | $w->Increment('down','little','initial') | |
160 | } | |
161 | elsif ($el eq 'slider') | |
162 | { | |
163 | $Tk::dragging = 1; | |
164 | my @coords = $w->coords(); | |
165 | $Tk::deltaX = $x-$coords[0]; | |
166 | $Tk::deltaY = $y-$coords[1]; | |
167 | } | |
168 | } | |
169 | # Drag -- | |
170 | # This procedure is called when the mouse is dragged with | |
171 | # mouse button 1 down. If the drag started inside the slider | |
172 | # (i.e. the scale is active) then the scale's value is adjusted | |
173 | # to reflect the mouse's position. | |
174 | # | |
175 | # Arguments: | |
176 | # w - The scale widget. | |
177 | # x, y - Mouse coordinates. | |
178 | sub Drag | |
179 | { | |
180 | my $w = shift; | |
181 | my $x = shift; | |
182 | my $y = shift; | |
183 | if (!$Tk::dragging) | |
184 | { | |
185 | return; | |
186 | } | |
187 | $w->set($w->get($x-$Tk::deltaX,$y-$Tk::deltaY)) | |
188 | } | |
189 | # EndDrag -- | |
190 | # This procedure is called to end an interactive drag of the | |
191 | # slider. It just marks the drag as over. | |
192 | # Arguments: | |
193 | # w - The scale widget. | |
194 | sub EndDrag | |
195 | { | |
196 | my $w = shift; | |
197 | if (!$Tk::dragging) | |
198 | { | |
199 | return; | |
200 | } | |
201 | $Tk::dragging = 0; | |
202 | } | |
203 | # Increment -- | |
204 | # This procedure is invoked to increment the value of a scale and | |
205 | # to set up auto-repeating of the action if that is desired. The | |
206 | # way the value is incremented depends on the "dir" and "big" | |
207 | # arguments. | |
208 | # | |
209 | # Arguments: | |
210 | # w - The scale widget. | |
211 | # dir - "up" means move value towards -from, "down" means | |
212 | # move towards -to. | |
213 | # big - Size of increments: "big" or "little". | |
214 | # repeat - Whether and how to auto-repeat the action: "noRepeat" | |
215 | # means don't auto-repeat, "initial" means this is the | |
216 | # first action in an auto-repeat sequence, and "again" | |
217 | # means this is the second repetition or later. | |
218 | sub Increment | |
219 | { | |
220 | my $w = shift; | |
221 | my $dir = shift; | |
222 | my $big = shift; | |
223 | my $repeat = shift; | |
224 | my $inc; | |
225 | if ($big eq 'big') | |
226 | { | |
227 | $inc = $w->cget('-bigincrement'); | |
228 | if ($inc == 0) | |
229 | { | |
230 | $inc = abs(($w->cget('-to')-$w->cget('-from')))/10.0 | |
231 | } | |
232 | if ($inc < $w->cget('-resolution')) | |
233 | { | |
234 | $inc = $w->cget('-resolution') | |
235 | } | |
236 | } | |
237 | else | |
238 | { | |
239 | $inc = $w->cget('-resolution') | |
240 | } | |
241 | if (($w->cget('-from') > $w->cget('-to')) ^ ($dir eq 'up')) | |
242 | { | |
243 | $inc = -$inc | |
244 | } | |
245 | $w->set($w->get()+$inc); | |
246 | if ($repeat eq 'again') | |
247 | { | |
248 | $w->RepeatId($w->after($w->cget('-repeatinterval'),'Increment',$w,$dir,$big,'again')); | |
249 | } | |
250 | elsif ($repeat eq 'initial') | |
251 | { | |
252 | $w->RepeatId($w->after($w->cget('-repeatdelay'),'Increment',$w,$dir,$big,'again')); | |
253 | } | |
254 | } | |
255 | # ControlPress -- | |
256 | # This procedure handles button presses that are made with the Control | |
257 | # key down. Depending on the mouse position, it adjusts the scale | |
258 | # value to one end of the range or the other. | |
259 | # | |
260 | # Arguments: | |
261 | # w - The scale widget. | |
262 | # x, y - Mouse coordinates where the button was pressed. | |
263 | sub ControlPress | |
264 | { | |
265 | my ($w,$x,$y) = @_; | |
266 | my $el = $w->identify($x,$y); | |
267 | return unless ($el); | |
268 | if ($el eq 'trough1') | |
269 | { | |
270 | $w->set($w->cget('-from')) | |
271 | } | |
272 | elsif ($el eq 'trough2') | |
273 | { | |
274 | $w->set($w->cget('-to')) | |
275 | } | |
276 | } | |
277 | ||
278 |