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