Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Conversion from Tk4.0 scrollbar.tcl competed. |
2 | package Tk::Scrollbar; | |
3 | require Tk; | |
4 | import Tk qw($XS_VERSION); | |
5 | use AutoLoader; | |
6 | ||
7 | use vars qw($VERSION); | |
8 | $VERSION = '3.014'; # $Id: //depot/Tk8/Scrollbar/Scrollbar.pm#14 $ | |
9 | ||
10 | use base qw(Tk::Widget); | |
11 | ||
12 | Construct Tk::Widget 'Scrollbar'; | |
13 | ||
14 | bootstrap Tk::Scrollbar; | |
15 | ||
16 | sub Tk_cmd { \&Tk::scrollbar } | |
17 | ||
18 | Tk::Methods('activate','delta','fraction','get','identify','set'); | |
19 | ||
20 | sub Needed | |
21 | { | |
22 | my ($sb) = @_; | |
23 | my @val = $sb->get; | |
24 | return 1 unless (@val == 2); | |
25 | return 1 if $val[0] != 0.0; | |
26 | return 1 if $val[1] != 1.0; | |
27 | return 0; | |
28 | } | |
29 | ||
30 | ||
31 | sub ClassInit | |
32 | { | |
33 | my ($class,$mw) = @_; | |
34 | $mw->bind($class, '<Enter>', 'Enter'); | |
35 | $mw->bind($class, '<Motion>', 'Motion'); | |
36 | $mw->bind($class, '<Leave>', 'Leave'); | |
37 | ||
38 | $mw->bind($class, '<1>', 'ButtonDown'); | |
39 | $mw->bind($class, '<B1-Motion>', 'Drag'); | |
40 | $mw->bind($class, '<ButtonRelease-1>', 'ButtonUp'); | |
41 | $mw->bind($class, '<B1-Leave>', 'NoOp'); # prevent generic <Leave> | |
42 | $mw->bind($class, '<B1-Enter>', 'NoOp'); # prevent generic <Enter> | |
43 | $mw->bind($class, '<Control-1>', 'ScrlTopBottom'); | |
44 | ||
45 | $mw->bind($class, '<2>', 'ButtonDown'); | |
46 | $mw->bind($class, '<B2-Motion>', 'Drag'); | |
47 | $mw->bind($class, '<ButtonRelease-2>', 'ButtonUp'); | |
48 | $mw->bind($class, '<B2-Leave>', 'NoOp'); # prevent generic <Leave> | |
49 | $mw->bind($class, '<B2-Enter>', 'NoOp'); # prevent generic <Enter> | |
50 | $mw->bind($class, '<Control-2>', 'ScrlTopBottom'); | |
51 | ||
52 | $mw->bind($class, '<Up>', ['ScrlByUnits','v',-1]); | |
53 | $mw->bind($class, '<Down>', ['ScrlByUnits','v', 1]); | |
54 | $mw->bind($class, '<Control-Up>', ['ScrlByPages','v',-1]); | |
55 | $mw->bind($class, '<Control-Down>', ['ScrlByPages','v', 1]); | |
56 | ||
57 | $mw->bind($class, '<Left>', ['ScrlByUnits','h',-1]); | |
58 | $mw->bind($class, '<Right>', ['ScrlByUnits','h', 1]); | |
59 | $mw->bind($class, '<Control-Left>', ['ScrlByPages','h',-1]); | |
60 | $mw->bind($class, '<Control-Right>', ['ScrlByPages','h', 1]); | |
61 | ||
62 | $mw->bind($class, '<Prior>', ['ScrlByPages','hv',-1]); | |
63 | $mw->bind($class, '<Next>', ['ScrlByPages','hv', 1]); | |
64 | ||
65 | $mw->bind($class, '<Home>', ['ScrlToPos', 0]); | |
66 | $mw->bind($class, '<End>', ['ScrlToPos', 1]); | |
67 | ||
68 | return $class; | |
69 | ||
70 | } | |
71 | ||
72 | 1; | |
73 | ||
74 | __END__ | |
75 | ||
76 | sub Enter | |
77 | { | |
78 | my $w = shift; | |
79 | my $e = $w->XEvent; | |
80 | if ($Tk::strictMotif) | |
81 | { | |
82 | my $bg = $w->cget('-background'); | |
83 | $activeBg = $w->cget('-activebackground'); | |
84 | $w->configure('-activebackground' => $bg); | |
85 | } | |
86 | $w->activate($w->identify($e->x,$e->y)); | |
87 | } | |
88 | ||
89 | sub Leave | |
90 | { | |
91 | my $w = shift; | |
92 | if ($Tk::strictMotif) | |
93 | { | |
94 | $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ; | |
95 | } | |
96 | $w->activate(''); | |
97 | } | |
98 | ||
99 | sub Motion | |
100 | { | |
101 | my $w = shift; | |
102 | my $e = $w->XEvent; | |
103 | $w->activate($w->identify($e->x,$e->y)); | |
104 | } | |
105 | ||
106 | # tkScrollButtonDown -- | |
107 | # This procedure is invoked when a button is pressed in a scrollbar. | |
108 | # It changes the way the scrollbar is displayed and takes actions | |
109 | # depending on where the mouse is. | |
110 | # | |
111 | # Arguments: | |
112 | # w - The scrollbar widget. | |
113 | # x, y - Mouse coordinates. | |
114 | ||
115 | sub ButtonDown | |
116 | {my $w = shift; | |
117 | my $e = $w->XEvent; | |
118 | my $element = $w->identify($e->x,$e->y); | |
119 | $w->configure('-activerelief' => 'sunken'); | |
120 | if ($e->b == 1 and | |
121 | (defined($element) && $element eq 'slider')) | |
122 | { | |
123 | $w->StartDrag($e->x,$e->y); | |
124 | } | |
125 | elsif ($e->b == 2 and | |
126 | (defined($element) && $element =~ /^(trough[12]|slider)$/o)) | |
127 | { | |
128 | my $pos = $w->fraction($e->x, $e->y); | |
129 | my($head, $tail) = $w->get; | |
130 | my $len = $tail - $head; | |
131 | ||
132 | $head = $pos - $len/2; | |
133 | $tail = $pos + $len/2; | |
134 | if ($head < 0) { | |
135 | $head = 0; | |
136 | $tail = $len; | |
137 | } | |
138 | elsif ($tail > 1) { | |
139 | $head = 1 - $len; | |
140 | $tail = 1; | |
141 | } | |
142 | $w->ScrlToPos($head); | |
143 | $w->set($head, $tail); | |
144 | ||
145 | $w->StartDrag($e->x,$e->y); | |
146 | } | |
147 | else | |
148 | { | |
149 | $w->Select($element,'initial'); | |
150 | } | |
151 | } | |
152 | ||
153 | # tkScrollButtonUp -- | |
154 | # This procedure is invoked when a button is released in a scrollbar. | |
155 | # It cancels scans and auto-repeats that were in progress, and restores | |
156 | # the way the active element is displayed. | |
157 | # | |
158 | # Arguments: | |
159 | # w - The scrollbar widget. | |
160 | # x, y - Mouse coordinates. | |
161 | ||
162 | sub ButtonUp | |
163 | {my $w = shift; | |
164 | my $e = $w->XEvent; | |
165 | $w->CancelRepeat; | |
166 | $w->configure('-activerelief' => 'raised'); | |
167 | $w->EndDrag($e->x,$e->y); | |
168 | $w->activate($w->identify($e->x,$e->y)); | |
169 | } | |
170 | ||
171 | # tkScrollSelect -- | |
172 | # This procedure is invoked when button 1 is pressed over the scrollbar. | |
173 | # It invokes one of several scrolling actions depending on where in | |
174 | # the scrollbar the button was pressed. | |
175 | # | |
176 | # Arguments: | |
177 | # w - The scrollbar widget. | |
178 | # element - The element of the scrollbar that was selected, such | |
179 | # as "arrow1" or "trough2". Shouldn't be "slider". | |
180 | # repeat - Whether and how to auto-repeat the action: "noRepeat" | |
181 | # means don't auto-repeat, "initial" means this is the | |
182 | # first action in an auto-repeat sequence, and "again" | |
183 | # means this is the second repetition or later. | |
184 | ||
185 | sub Select | |
186 | { | |
187 | my $w = shift; | |
188 | my $element = shift; | |
189 | my $repeat = shift; | |
190 | return unless defined ($element); | |
191 | if ($element eq 'arrow1') | |
192 | { | |
193 | $w->ScrlByUnits('hv',-1); | |
194 | } | |
195 | elsif ($element eq 'trough1') | |
196 | { | |
197 | $w->ScrlByPages('hv',-1); | |
198 | } | |
199 | elsif ($element eq 'trough2') | |
200 | { | |
201 | $w->ScrlByPages('hv', 1); | |
202 | } | |
203 | elsif ($element eq 'arrow2') | |
204 | { | |
205 | $w->ScrlByUnits('hv', 1); | |
206 | } | |
207 | else | |
208 | { | |
209 | return; | |
210 | } | |
211 | ||
212 | if ($repeat eq 'again') | |
213 | { | |
214 | $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again'])); | |
215 | } | |
216 | elsif ($repeat eq 'initial') | |
217 | { | |
218 | $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again'])); | |
219 | } | |
220 | } | |
221 | ||
222 | # tkScrollStartDrag -- | |
223 | # This procedure is called to initiate a drag of the slider. It just | |
224 | # remembers the starting position of the slider. | |
225 | # | |
226 | # Arguments: | |
227 | # w - The scrollbar widget. | |
228 | # x, y - The mouse position at the start of the drag operation. | |
229 | ||
230 | sub StartDrag | |
231 | {my $w = shift; | |
232 | my $x = shift; | |
233 | my $y = shift; | |
234 | return unless (defined ($w->cget('-command'))); | |
235 | $initMouse = $w->fraction($x,$y); | |
236 | @initValues = $w->get(); | |
237 | if (@initValues == 2) | |
238 | { | |
239 | $initPos = $initValues[0]; | |
240 | } | |
241 | else | |
242 | { | |
243 | $initPos = $initValues[2] / $initValues[0]; | |
244 | } | |
245 | } | |
246 | ||
247 | # tkScrollDrag -- | |
248 | # This procedure is called for each mouse motion even when the slider | |
249 | # is being dragged. It notifies the associated widget if we're not | |
250 | # jump scrolling, and it just updates the scrollbar if we are jump | |
251 | # scrolling. | |
252 | # | |
253 | # Arguments: | |
254 | # w - The scrollbar widget. | |
255 | # x, y - The current mouse position. | |
256 | ||
257 | sub Drag | |
258 | {my $w = shift; | |
259 | my $e = $w->XEvent; | |
260 | return unless (defined $initMouse); | |
261 | my $f = $w->fraction($e->x,$e->y); | |
262 | my $delta = $f - $initMouse; | |
263 | if ($w->cget('-jump')) | |
264 | { | |
265 | if (@initValues == 2) | |
266 | { | |
267 | $w->set($initValues[0]+$delta,$initValues[1]+$delta); | |
268 | } | |
269 | else | |
270 | { | |
271 | $delta = int($delta * $initValues[0]); | |
272 | $initValues[2] += $delta; | |
273 | $initValues[3] += $delta; | |
274 | $w->set(@initValues); | |
275 | } | |
276 | } | |
277 | else | |
278 | { | |
279 | $w->ScrlToPos($initPos+$delta); | |
280 | } | |
281 | } | |
282 | ||
283 | # tkScrollEndDrag -- | |
284 | # This procedure is called to end an interactive drag of the slider. | |
285 | # It scrolls the window if we're in jump mode, otherwise it does nothing. | |
286 | # | |
287 | # Arguments: | |
288 | # w - The scrollbar widget. | |
289 | # x, y - The mouse position at the end of the drag operation. | |
290 | ||
291 | sub EndDrag | |
292 | { | |
293 | my $w = shift; | |
294 | my $x = shift; | |
295 | my $y = shift; | |
296 | return unless defined($initMouse); | |
297 | if ($w->cget('-jump')) | |
298 | { | |
299 | $w->ScrlToPos($initPos + $w->fraction($x,$y) - $initMouse); | |
300 | } | |
301 | undef $initMouse; | |
302 | } | |
303 | ||
304 | # tkScrlByUnits -- | |
305 | # This procedure tells the scrollbar's associated widget to scroll up | |
306 | # or down by a given number of units. It notifies the associated widget | |
307 | # in different ways for old and new command syntaxes. | |
308 | # | |
309 | # Arguments: | |
310 | # w - The scrollbar widget. | |
311 | # orient - Which kinds of scrollbars this applies to: "h" for | |
312 | # horizontal, "v" for vertical, "hv" for both. | |
313 | # amount - How many units to scroll: typically 1 or -1. | |
314 | ||
315 | sub ScrlByUnits | |
316 | {my $w = shift; | |
317 | my $orient = shift; | |
318 | my $amount = shift; | |
319 | my $cmd = $w->cget('-command'); | |
320 | return unless (defined $cmd); | |
321 | return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); | |
322 | my @info = $w->get; | |
323 | if (@info == 2) | |
324 | { | |
325 | $cmd->Call('scroll',$amount,'units'); | |
326 | } | |
327 | else | |
328 | { | |
329 | $cmd->Call($info[2]+$amount); | |
330 | } | |
331 | } | |
332 | ||
333 | # tkScrlByPages -- | |
334 | # This procedure tells the scrollbar's associated widget to scroll up | |
335 | # or down by a given number of screenfuls. It notifies the associated | |
336 | # widget in different ways for old and new command syntaxes. | |
337 | # | |
338 | # Arguments: | |
339 | # w - The scrollbar widget. | |
340 | # orient - Which kinds of scrollbars this applies to: "h" for | |
341 | # horizontal, "v" for vertical, "hv" for both. | |
342 | # amount - How many screens to scroll: typically 1 or -1. | |
343 | ||
344 | sub ScrlByPages | |
345 | { | |
346 | my $w = shift; | |
347 | my $orient = shift; | |
348 | my $amount = shift; | |
349 | my $cmd = $w->cget('-command'); | |
350 | return unless (defined $cmd); | |
351 | return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); | |
352 | my @info = $w->get; | |
353 | if (@info == 2) | |
354 | { | |
355 | $cmd->Call('scroll',$amount,'pages'); | |
356 | } | |
357 | else | |
358 | { | |
359 | $cmd->Call($info[2]+$amount*($info[1]-1)); | |
360 | } | |
361 | } | |
362 | ||
363 | # tkScrlToPos -- | |
364 | # This procedure tells the scrollbar's associated widget to scroll to | |
365 | # a particular location, given by a fraction between 0 and 1. It notifies | |
366 | # the associated widget in different ways for old and new command syntaxes. | |
367 | # | |
368 | # Arguments: | |
369 | # w - The scrollbar widget. | |
370 | # pos - A fraction between 0 and 1 indicating a desired position | |
371 | # in the document. | |
372 | ||
373 | sub ScrlToPos | |
374 | { | |
375 | my $w = shift; | |
376 | my $pos = shift; | |
377 | my $cmd = $w->cget('-command'); | |
378 | return unless (defined $cmd); | |
379 | my @info = $w->get; | |
380 | if (@info == 2) | |
381 | { | |
382 | $cmd->Call('moveto',$pos); | |
383 | } | |
384 | else | |
385 | { | |
386 | $cmd->Call(int($info[0]*$pos)); | |
387 | } | |
388 | } | |
389 | ||
390 | # tkScrlTopBottom | |
391 | # Scroll to the top or bottom of the document, depending on the mouse | |
392 | # position. | |
393 | # | |
394 | # Arguments: | |
395 | # w - The scrollbar widget. | |
396 | # x, y - Mouse coordinates within the widget. | |
397 | ||
398 | sub ScrlTopBottom | |
399 | { | |
400 | my $w = shift; | |
401 | my $e = $w->XEvent; | |
402 | my $element = $w->identify($e->x,$e->y); | |
403 | return unless ($element); | |
404 | if ($element =~ /1$/) | |
405 | { | |
406 | $w->ScrlToPos(0); | |
407 | } | |
408 | elsif ($element =~ /2$/) | |
409 | { | |
410 | $w->ScrlToPos(1); | |
411 | } | |
412 | } | |
413 | ||
414 |