Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::ProgressBar; |
2 | ||
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.014'; # $Id: //depot/Tk8/Tk/ProgressBar.pm#14 $ | |
5 | ||
6 | use Tk; | |
7 | use Tk::Canvas; | |
8 | use Carp; | |
9 | use strict; | |
10 | ||
11 | use base qw(Tk::Derived Tk::Canvas); | |
12 | ||
13 | Construct Tk::Widget 'ProgressBar'; | |
14 | ||
15 | sub ClassInit { | |
16 | my ($class,$mw) = @_; | |
17 | ||
18 | $class->SUPER::ClassInit($mw); | |
19 | ||
20 | $mw->bind($class,'<Configure>', ['_layoutRequest',1]); | |
21 | } | |
22 | ||
23 | ||
24 | sub Populate { | |
25 | my($c,$args) = @_; | |
26 | ||
27 | $c->ConfigSpecs( | |
28 | -width => [PASSIVE => undef, undef, 0], | |
29 | '-length' => [PASSIVE => undef, undef, 0], | |
30 | -from => [PASSIVE => undef, undef, 0], | |
31 | -to => [PASSIVE => undef, undef, 100], | |
32 | -blocks => [PASSIVE => undef, undef, 10], | |
33 | -padx => [PASSIVE => 'padX', 'Pad', 0], | |
34 | -pady => [PASSIVE => 'padY', 'Pad', 0], | |
35 | -gap => [PASSIVE => undef, undef, 1], | |
36 | -colors => [PASSIVE => undef, undef, undef], | |
37 | -relief => [SELF => 'relief', 'Relief', 'sunken'], | |
38 | -value => [METHOD => undef, undef, undef], | |
39 | -variable => [METHOD => undef, undef, undef], | |
40 | -anchor => [METHOD => 'anchor', 'Anchor', 'w'], | |
41 | -resolution | |
42 | => [PASSIVE => undef, undef, 1.0], | |
43 | -highlightthickness | |
44 | => [SELF => 'highlightThickness','HighlightThickness',0], | |
45 | -troughcolor | |
46 | => [PASSIVE => 'troughColor', 'Background', 'grey55'], | |
47 | ); | |
48 | _layoutRequest($c,1); | |
49 | $c->OnDestroy(['Destroyed' => $c]); | |
50 | } | |
51 | ||
52 | sub anchor { | |
53 | my $c = shift; | |
54 | my $var = \$c->{Configure}{'-anchor'}; | |
55 | my $old = $$var; | |
56 | ||
57 | if(@_) { | |
58 | my $new = shift; | |
59 | croak "bad anchor position \"$new\": must be n, s, w or e" | |
60 | unless $new =~ /^[news]$/; | |
61 | $$var = $new; | |
62 | } | |
63 | ||
64 | $old; | |
65 | } | |
66 | ||
67 | sub _layoutRequest { | |
68 | my $c = shift; | |
69 | my $why = shift; | |
70 | $c->afterIdle(['_arrange',$c]) unless $c->{'layout_pending'}; | |
71 | $c->{'layout_pending'} |= $why; | |
72 | } | |
73 | ||
74 | sub _arrange { | |
75 | my $c = shift; | |
76 | my $why = $c->{'layout_pending'}; | |
77 | ||
78 | $c->{'layout_pending'} = 0; | |
79 | ||
80 | my $w = $c->Width; | |
81 | my $h = $c->Height; | |
82 | my $bw = $c->cget('-borderwidth') + $c->cget('-highlightthickness'); | |
83 | my $x = abs(int($c->{Configure}{'-padx'})) + $bw; | |
84 | my $y = abs(int($c->{Configure}{'-pady'})) + $bw; | |
85 | my $value = $c->value; | |
86 | my $from = $c->{Configure}{'-from'}; | |
87 | my $to = $c->{Configure}{'-to'}; | |
88 | my $horz = $c->{Configure}{'-anchor'} =~ /[ew]/i ? 1 : 0; | |
89 | my $dir = $c->{Configure}{'-anchor'} =~ /[ne]/i ? -1 : 1; | |
90 | ||
91 | my($minv,$maxv) = $from < $to ? ($from,$to) : ($to,$from); | |
92 | ||
93 | if($w == 1 && $h == 1) { | |
94 | my $bw = $c->cget('-borderwidth'); | |
95 | my $defw = 10 + $y*2 + $bw *2; | |
96 | my $defl = ($maxv - $minv) + $x*2 + $bw*2; | |
97 | ||
98 | $h = $c->pixels($c->{Configure}{'-length'}) || $defl; | |
99 | $w = $c->pixels($c->{Configure}{'-width'}) || $defw; | |
100 | ||
101 | ($w,$h) = ($h,$w) if $horz; | |
102 | $c->GeometryRequest($w,$h); | |
103 | $c->parent->update; | |
104 | $c->update; | |
105 | ||
106 | $w = $c->Width; | |
107 | $h = $c->Height; | |
108 | } | |
109 | ||
110 | $w -= $x*2; | |
111 | $h -= $y*2; | |
112 | ||
113 | my $length = $horz ? $w : $h; | |
114 | my $width = $horz ? $h : $w; | |
115 | ||
116 | my $blocks = int($c->{Configure}{'-blocks'}); | |
117 | my $gap = int($c->{Configure}{'-gap'}); | |
118 | ||
119 | $blocks = 1 if $blocks < 1; | |
120 | ||
121 | my $gwidth = $gap * ( $blocks - 1); | |
122 | my $bwidth = ($length - $gwidth) / $blocks; | |
123 | ||
124 | if($bwidth < 3 || $blocks <= 1 || $gap <= 0) { | |
125 | $blocks = 1; | |
126 | $bwidth = $length; | |
127 | $gap = 0; | |
128 | } | |
129 | ||
130 | if($why & 1) { | |
131 | my $colors = $c->{Configure}{'-colors'} || []; | |
132 | my $bdir = $from < $to ? $dir : 0 - $dir; | |
133 | ||
134 | $c->delete($c->find('all')); | |
135 | ||
136 | $c->createRectangle(0,0,$w+$x*2,$h+$y*2, | |
137 | -fill => $c->{Configure}{'-troughcolor'}, | |
138 | -width => 0, | |
139 | -outline => undef); | |
140 | ||
141 | $c->{'cover'} = $c->createRectangle($x,$y,$w,$h, | |
142 | -fill => $c->{Configure}{'-troughcolor'}, | |
143 | -width => 0, | |
144 | -outline => undef); | |
145 | ||
146 | my($x0,$y0,$x1,$y1); | |
147 | ||
148 | if($horz) { | |
149 | if($bdir > 0) { | |
150 | ($x0,$y0) = ($x - $gap,$y); | |
151 | } | |
152 | else { | |
153 | ($x0,$y0) = ($length + $x + $gap,$y); | |
154 | } | |
155 | ($x1,$y1) = ($x0,$y0 + $width); | |
156 | } | |
157 | else { | |
158 | if($bdir > 0) { | |
159 | ($x0,$y0) = ($x,$y - $gap); | |
160 | } | |
161 | else { | |
162 | ($x0,$y0) = ($x,$length + $y + $gap); | |
163 | } | |
164 | ($x1,$y1) = ($x0 + $width,$y0); | |
165 | } | |
166 | ||
167 | my $blks = $blocks; | |
168 | my $dval = ($maxv - $minv) / $blocks; | |
169 | my $color = $c->cget('-foreground'); | |
170 | my $pos = 0; | |
171 | my $val = $minv; | |
172 | ||
173 | while($val < $maxv) { | |
174 | my($bw,$nval); | |
175 | ||
176 | while(($pos < @$colors) && $colors->[$pos] <= $val) { | |
177 | $color = $colors->[$pos+1]; | |
178 | $pos += 2; | |
179 | } | |
180 | ||
181 | if($blocks == 1) { | |
182 | $nval = defined($colors->[$pos]) | |
183 | ? $colors->[$pos] : $maxv; | |
184 | $bw = (($nval - $val) / ($maxv - $minv)) * $length; | |
185 | } | |
186 | else { | |
187 | $bw = $bwidth; | |
188 | $nval = $val + $dval if($blocks > 1); | |
189 | } | |
190 | ||
191 | if($horz) { | |
192 | if($bdir > 0) { | |
193 | $x0 = $x1 + $gap; | |
194 | $x1 = $x0 + $bw; | |
195 | } | |
196 | else { | |
197 | $x1 = $x0 - $gap; | |
198 | $x0 = $x1 - $bw; | |
199 | } | |
200 | } | |
201 | else { | |
202 | if($bdir > 0) { | |
203 | $y0 = $y1 + $gap; | |
204 | $y1 = $y0 + $bw; | |
205 | } | |
206 | else { | |
207 | $y1 = $y0 - $gap; | |
208 | $y0 = $y1 - $bw; | |
209 | } | |
210 | } | |
211 | ||
212 | $c->createRectangle($x0,$y0,$x1,$y1, | |
213 | -fill => $color, | |
214 | -width => 0, | |
215 | -outline => undef | |
216 | ); | |
217 | $val = $nval; | |
218 | } | |
219 | } | |
220 | ||
221 | my $cover = $c->{'cover'}; | |
222 | my $ddir = $from > $to ? 1 : -1; | |
223 | ||
224 | if(($value <=> $to) == (0-$ddir)) { | |
225 | $c->lower($cover); | |
226 | } | |
227 | elsif(($value <=> $from) == $ddir) { | |
228 | $c->raise($cover); | |
229 | my $x1 = $horz ? $x + $length : $x + $width; | |
230 | my $y1 = $horz ? $y + $width : $y + $length; | |
231 | $c->coords($cover,$x,$y,$x1,$y1); | |
232 | } | |
233 | else { | |
234 | my $step; | |
235 | $value = int($value / $step) * $step | |
236 | if(defined($step = $c->{Configure}{'-resolution'}) && $step > 0); | |
237 | ||
238 | $maxv = $minv+1 | |
239 | if $minv == $maxv; | |
240 | ||
241 | my $range = $maxv - $minv; | |
242 | my $bval = $range / $blocks; | |
243 | my $offset = abs($value - $from); | |
244 | my $ioff = int($offset / $bval); | |
245 | my $start = $ioff * ($bwidth + $gap); | |
246 | $start += ($offset - ($ioff * $bval)) / $bval * $bwidth; | |
247 | ||
248 | my($x0,$x1,$y0,$y1); | |
249 | ||
250 | if($horz) { | |
251 | $y0 = $y; | |
252 | $y1 = $y + $h; | |
253 | if($dir > 0) { | |
254 | $x0 = $x + $start; | |
255 | $x1 = $x + $w; | |
256 | } | |
257 | else { | |
258 | $x0 = $x; | |
259 | $x1 = $w + $x - $start; | |
260 | } | |
261 | } | |
262 | else { | |
263 | $x0 = $x; | |
264 | $x1 = $x + $w; | |
265 | if($dir > 0) { | |
266 | $y0 = $y + $start; | |
267 | $y1 = $y + $h; | |
268 | } | |
269 | else { | |
270 | $y0 = $y; | |
271 | $y1 = $h + $y - $start; | |
272 | } | |
273 | } | |
274 | ||
275 | ||
276 | $c->raise($cover); | |
277 | $c->coords($cover,$x0,$y0,$x1,$y1); | |
278 | } | |
279 | } | |
280 | ||
281 | sub value { | |
282 | my $c = shift; | |
283 | my $val = defined($c->{'-variable'}) | |
284 | ? $c->{'-variable'} | |
285 | : \$c->{'-value'}; | |
286 | my $old = defined($$val) ? $$val : $c->{Configure}{'-from'}; | |
287 | ||
288 | if(@_) { | |
289 | my $value = shift; | |
290 | $$val = defined($value) ? $value : $c->{Configure}{'-from'}; | |
291 | _layoutRequest($c,2); | |
292 | } | |
293 | ||
294 | $old; | |
295 | } | |
296 | ||
297 | sub variable { | |
298 | my $c = shift; | |
299 | my $val = \$c->{'-variable'}; | |
300 | my $old = $$val; | |
301 | if(@_) { | |
302 | my $value = shift; | |
303 | if (ref $old) | |
304 | { | |
305 | $c->{'-value'} = $$old; | |
306 | untie $$old if tied($$old); | |
307 | } | |
308 | tie $$value,'Tk::Configure',$c,'-value'; | |
309 | $$val = $value; | |
310 | _layoutRequest($c,2); | |
311 | } | |
312 | $old; | |
313 | } | |
314 | ||
315 | sub Destroyed | |
316 | { | |
317 | my $c = shift; | |
318 | my $var = delete $c->{'-variable'}; | |
319 | untie $$var if (defined($var) && ref($var)) | |
320 | } | |
321 | ||
322 | 1; | |
323 | __END__ | |
324 | ||
325 | =head1 NAME | |
326 | ||
327 | Tk::ProgressBar - A graphical progress bar | |
328 | ||
329 | =for category Derived Widgets | |
330 | ||
331 | =head1 SYNOPSIS | |
332 | ||
333 | use Tk::ProgressBar; | |
334 | ||
335 | $progress = $parent->ProgressBar( | |
336 | -width => 200, | |
337 | -length => 20, | |
338 | -anchor => 's', | |
339 | -from => 0, | |
340 | -to => 100, | |
341 | -blocks => 10, | |
342 | -colors => [0, 'green', 50, 'yellow' , 80, 'red'], | |
343 | -variable => \$percent_done | |
344 | ); | |
345 | ||
346 | $progress->value($position); | |
347 | ||
348 | =head1 DESCRIPTION | |
349 | ||
350 | B<Tk::ProgressBar> provides a widget which will show a graphical representation | |
351 | of a value, given maximum and minimum reference values. | |
352 | ||
353 | =head1 STANDARD OPTIONS | |
354 | ||
355 | The following standard widget options are supported: | |
356 | ||
357 | =over 4 | |
358 | ||
359 | =item B<-borderwidth> | |
360 | ||
361 | =item B<-highlightthickness> | |
362 | ||
363 | Defaults to 0. | |
364 | ||
365 | =item B<-padx> | |
366 | ||
367 | Defaults to 0. | |
368 | ||
369 | =item B<-pady> | |
370 | ||
371 | Defaults to 0. | |
372 | ||
373 | =item B<-relief> | |
374 | ||
375 | Defaults to C<sunken> | |
376 | ||
377 | =item B<-troughcolor> | |
378 | ||
379 | The color to be used for the background (trough) of the progress bar. | |
380 | Default is to use grey55. | |
381 | ||
382 | =back | |
383 | ||
384 | =head1 WIDGET-SPECIFIC OPTIONS | |
385 | ||
386 | =over 4 | |
387 | ||
388 | =item B<-anchor> | |
389 | ||
390 | This can be used to position the start point of the bar. Default | |
391 | is 'w' (horizontal bar starting from the left). A vertical bar can be | |
392 | configured by using either 's' or 'n'. | |
393 | ||
394 | =item B<-blocks> | |
395 | ||
396 | This controls the number of blocks to be used to construct the progress | |
397 | bar. The default is to break the bar into 10 blocks. | |
398 | ||
399 | =item B<-colors> | |
400 | ||
401 | Controls the colors to be used for different positions of the progress bar. | |
402 | The colors should be supplied as a reference to an array containing pairs | |
403 | of positions and colors. | |
404 | ||
405 | -colors => [ 0, 'green', 50, 'red' ] | |
406 | ||
407 | means that for the range 0 to 50 the progress bar should be green | |
408 | and for higher values it should be red. | |
409 | ||
410 | ||
411 | =item B<-from> | |
412 | ||
413 | This sets the lower limit of the progress bar. If the bar is set to a | |
414 | value below the lower limt no bar will be displayed. Defaults to 0. | |
415 | See the C<-to> description for more information. | |
416 | ||
417 | =item B<-gap> | |
418 | ||
419 | This is the spacing (in pixels) between each block. Defaults to 1. | |
420 | Use 0 to get a continuous bar. | |
421 | ||
422 | ||
423 | =item B<-length> | |
424 | ||
425 | Specifies the desired long dimension of the ProgressBar in screen | |
426 | units (i.e. any of the forms acceptable to Tk_GetPixels). For vertical | |
427 | ProgressBars this is the ProgressBars height; for horizontal scales it | |
428 | is the ProgressBars width. The default length is calculated from the | |
429 | values of C<-padx>, C<-borderwidth>, C<-highlightthickness> and the | |
430 | difference between C<-from> and C<-to>. | |
431 | ||
432 | ||
433 | =item B<-resolution> | |
434 | ||
435 | A real value specifying the resolution for the scale. If this value is greater | |
436 | than zero then the scale's value will always be rounded to an even multiple of | |
437 | this value, as will tick marks and the endpoints of the scale. If the value is | |
438 | less than zero then no rounding occurs. Defaults to 1 (i.e., the value will be | |
439 | integral). | |
440 | ||
441 | =item B<-to> | |
442 | ||
443 | This sets the upper limit of the progress bar. If a value is specified | |
444 | (for example, using the C<value> method) that lies above this value the | |
445 | full progress bar will be displayed. Defaults to 100. | |
446 | ||
447 | ||
448 | ||
449 | =item B<-variable> | |
450 | ||
451 | Specifies the reference to a scalar variable to link to the ProgressBar. | |
452 | Whenever the value of the variable changes, the ProgressBar will upate | |
453 | to reflect this value. (See also the B<value> method below.) | |
454 | ||
455 | =item B<-value> | |
456 | ||
457 | The can be used to set the current position of the progress bar | |
458 | when used in conjunction with the standard C<configure>. It is | |
459 | usually recommended to use the B<value> method instead. | |
460 | ||
461 | ||
462 | =item B<-width> | |
463 | ||
464 | Specifies the desired narrow dimension of the ProgressBar in screen | |
465 | units (i.e. any of the forms acceptable to Tk_GetPixels). For | |
466 | vertical ProgressBars this is the ProgressBars width; for horizontal | |
467 | bars this is the ProgressBars height. The default width is derived | |
468 | from the values of C<-borderwidth> and C<-pady> and C<-highlightthickness>. | |
469 | ||
470 | =back | |
471 | ||
472 | =head1 WIDGET METHODS | |
473 | ||
474 | =over 4 | |
475 | ||
476 | =item I<$ProgressBar>-E<gt>B<value>(?I<value>?) | |
477 | ||
478 | If I<value> is omitted, returns the current value of the ProgressBar. If | |
479 | I<value> is given, the value of the ProgressBar is set. If I<$value> is | |
480 | given but undefined the value of the option B<-from> is used. | |
481 | ||
482 | =back | |
483 | ||
484 | ||
485 | =head1 AUTHOR | |
486 | ||
487 | Graham Barr E<lt>F<gbarr@pobox.com>E<gt> | |
488 | ||
489 | =head1 COPYRIGHT | |
490 | ||
491 | Copyright (c) 1997-1998 Graham Barr. All rights reserved. | |
492 | This program is free software; you can redistribute it and/or modify it | |
493 | under the same terms as Perl itself. | |
494 | ||
495 | =cut | |
496 | ||
497 |