File Coverage

blib/lib/Tk/BarberPole.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Tk::BarberPole;
2              
3 1     1   7957 use strict;
  1         3  
  1         42  
4 1     1   6 use vars qw/$VERSION/;
  1         3  
  1         52  
5 1     1   5 use constant PI_OVER_180 => 3.141592659 / 180;
  1         5  
  1         96  
6              
7             $VERSION = 0.01;
8              
9 1     1   3198 use Tk;
  0            
  0            
10             use base qw/Tk::Derived Tk::Canvas/;
11              
12             Construct Tk::Widget 'BarberPole';
13              
14             sub Populate {
15             my ($c, $args) = @_;
16              
17             $c->SUPER::Populate($args);
18              
19             $c->ConfigSpecs(
20             -width => [PASSIVE => undef, undef, 30],
21             -length => [PASSIVE => undef, undef, 100],
22             -stripewidth => [PASSIVE => undef, undef, 10],
23             -slant => [PASSIVE => undef, undef, 45],
24             -separation => [PASSIVE => undef, undef, 20],
25             -orientation => [PASSIVE => undef, undef, 'horizontal'],
26             -colors => [PASSIVE => undef, undef, [qw/red blue/]],
27             -delay => [METHOD => undef, undef, 50],
28             -highlightthickness => [SELF => 'highlightThickness','HighlightThickness',0],
29             -padx => [PASSIVE => 'padX', 'Pad', 0],
30             -pady => [PASSIVE => 'padY', 'Pad', 0],
31             -autostart => [PASSIVE => undef, undef, 1],
32             );
33              
34             $c->afterIdle(['_drawPole', $c]);
35             }
36              
37             sub _drawPole {
38             my $c = shift;
39              
40             # calculate the angle, once and for all.
41             # and other values.
42             $c->{Len} = $c->cget('-length');
43             $c->{Wid} = $c->cget('-width');
44             $c->{Angle} = $c->cget('-slant') * PI_OVER_180;
45             $c->{Inc} = $c->{Wid} * tan($c->{Angle});
46             $c->{Sep} = $c->cget('-separation');
47             $c->{StripeW} = $c->cget('-stripewidth');
48             $c->{Col} = $c->cget('-colors');
49             $c->{Ori} = $c->cget('-orientation');
50              
51             # set the correct canvas size.
52             my ($w, $h) = $c->{Ori} eq 'horizontal' ? @{$c}{qw/Len Wid/} : @{$c}{qw/Wid Len/};
53             my $bw = $c->cget('-borderwidth') + $c->cget('-highlightthickness');
54             my $padx = $c->cget('-padx');
55             my $pady = $c->cget('-pady');
56              
57             my $startX = $padx + $bw;
58             my $startY = $pady + $bw;
59              
60             $w += 2 * $startX;
61             $h += 2 * $startY;
62              
63             $c->GeometryRequest($w, $h);
64              
65             # draw the outline of the pole.
66             $c->createRectangle($startX, $startY, $w-$startX-1, $h - $startY-1,
67             -outline => 'black',
68             -tags => ['BORDER'],
69             );
70              
71             # now draw the stripes.
72             if ($c->{Ori} eq 'horizontal') {
73             my $x = -($c->{Inc} + $c->{StripeW});
74             my $y = $startY;
75             my $color = 0;
76              
77             while ($x < $c->{Len}) {
78             push @{$c->{Stripes}} =>
79             $c->createPolygon($x, $y, $x + $c->{Inc}, $y + $c->{Wid},
80             $x + $c->{Inc} + $c->{StripeW}, $y + $c->{Wid},
81             $x + $c->{StripeW}, $y,
82             -fill => $c->{Col}[$color % @{$c->{Col}}],
83             -tags => ['STRIPE'],
84             );
85              
86             $color ++;
87             $x += $c->{Sep};
88             }
89              
90             # make sure the number of poles are a multiple of the number of colors.
91             if (my $mod = @{$c->{Stripes}} % @{$c->{Col}}) {
92              
93             my $count = $#{$c->{Col}} - $mod;
94             my $x = -($c->{Inc} + $c->{StripeW} + $c->{Sep}) - $count * $c->{Sep};
95              
96             my @new;
97             for my $i (0 .. $count) {
98             push @new =>
99             $c->createPolygon($x, $startY, $x + $c->{Inc}, $startY + $c->{Wid},
100             $x + $c->{Inc} + $c->{StripeW}, $startY + $c->{Wid},
101             $x + $c->{StripeW}, $startY,
102             -fill => $c->{Col}[$color % @{$c->{Col}}],
103             -tags => ['STRIPE'],
104             );
105              
106             $color ++;
107             $x += $c->{Sep};
108             }
109              
110             unshift @{$c->{Stripes}} => @new;
111             }
112              
113             } else {
114             # vertical
115             my $x = $startX;
116             my $y = -($c->{Inc} + $c->{StripeW});
117             my $color = 0;
118              
119             while ($y < $c->{Len}) {
120             push @{$c->{Stripes}} =>
121             $c->createPolygon($x, $y, $x + $c->{Wid}, $y + $c->{Inc},
122             $x + $c->{Wid}, $y + $c->{Inc} + $c->{StripeW},
123             $x, $y + $c->{StripeW},
124             -fill => $c->{Col}[$color % @{$c->{Col}}],
125             -tags => ['STRIPE'],
126             );
127              
128             $color ++;
129             $y += $c->{Sep};
130             }
131              
132             # make sure the number of poles are a multiple of the number of colors.
133             if (my $mod = @{$c->{Stripes}} % @{$c->{Col}}) {
134              
135             my $count = $#{$c->{Col}} - $mod;
136             my $y = -($c->{Inc} + $c->{StripeW} + $c->{Sep}) - $count * $c->{Sep};
137             my @new;
138             for my $i (0 .. $count) {
139             push @new =>
140             $c->createPolygon($startX, $y, $startX + $c->{Wid}, $y + $c->{Inc},
141             $startX + $c->{Wid}, $y + $c->{Inc} + $c->{StripeW},
142             $startY, $y + $c->{StripeW},
143             -fill => $c->{Col}[$color % @{$c->{Col}}],
144             -tags => ['STRIPE'],
145             );
146              
147             $color ++;
148             $y += $c->{Sep};
149             }
150              
151             unshift @{$c->{Stripes}} => @new;
152             }
153             }
154              
155             # tag first stripe
156             $c->{First} = $c->{Stripes}[0];
157              
158             $c->raise('BORDER');
159              
160             $c->start if $c->cget('-autostart');
161             }
162              
163             sub _animate {
164             my $c = shift;
165              
166             # check for any stripes that are outside the visible area
167             # and move them to the beginning.
168              
169             my @visible = $c->find(overlapping => 0, 0, $c->{Len}, $c->{Wid});
170             my %h;
171             @h{@{$c->{Stripes}}} = 1;
172             delete $h{$_} for @visible;
173              
174             for my $id (keys %h) {
175             # find how far each stripe is from the end of the pole,
176             # and move it the same distance away from the first stripe.
177              
178             my @c = $c->coords($id);
179              
180             my $dist = $c->{Ori} eq 'horizontal' ? $c[0] - $c->{Len} : $c[1] - $c->{Len};
181             next if $dist < 0; # before the beginning.
182              
183             # calculate offset
184             my @f = $c->coords($c->{First});
185             my $offset = $c->{Ori} eq 'horizontal' ?
186             ($c[0] - $f[0]) + $c->{Sep} :
187             ($c[1] - $f[1]) + $c->{Sep};
188              
189             # move it.
190             $c->move($id, $c->{Ori} eq 'horizontal' ? (-$offset, 0) : (0, -$offset));
191             $c->{First} = $id;
192             }
193              
194             # now move everything.
195             $c->move(STRIPE => $c->{Ori} eq 'horizontal' ? (1, 0) : (0, 1));
196             }
197              
198             sub delay {
199             my ($c, $v) = @_;
200              
201             if (defined $v) {
202             $c->{Delay} = $v;
203             }
204              
205             if ($c->{Anim}) {
206             $c->afterCancel($c->{RepID});
207             $c->{RepID} = $c->repeat($c->{Delay}, ['_animate', $c]);
208             }
209              
210             return $c->{Delay};
211             }
212              
213             sub start {
214             my $c = shift;
215              
216             return if $c->{Anim};
217              
218             # now start the animation
219             $c->{RepID} = $c->repeat($c->{Delay}, ['_animate', $c]);
220             $c->{Anim} = 1;
221             }
222              
223             sub stop {
224             my $c = shift;
225              
226             return unless $c->{Anim};
227              
228             # now stop the animation
229             $c->afterCancel($c->{RepID});
230             $c->{Anim} = 0;
231             }
232              
233             sub tan { sin($_[0]) / cos($_[0]) }
234              
235             1;
236              
237             __END__