Tk::BarberPole - A rotating barber pole

    use Tk::BarberPole;

    $pole = $parent->BarberPole(
	-width       => 200,
	-length      => 20,
	-bg          => 'white',
        -orientation => 'vertical',
	-colors      => [qw/red blue/],

	-slant       => 38,
        -stripewidth => 15,
        -separation  => 35,

        -delay       => 50,
        -autostart   => 1,
    );

    $pole->start;
    $pole->stop;

        perl Makefile.PL
        make
        make install

package Tk::BarberPole;

use strict;
use vars qw/$VERSION/;
use constant PI_OVER_180 => 3.141592659 / 180;

$VERSION = 0.01;

use Tk;
use base qw/Tk::Derived Tk::Canvas/;

Construct Tk::Widget 'BarberPole';

sub Populate {
  my ($c, $args) = @_;

  $c->SUPER::Populate($args);

  $c->ConfigSpecs(
		  -width              => [PASSIVE => undef, undef, 30],
		  -length             => [PASSIVE => undef, undef, 100],
		  -stripewidth        => [PASSIVE => undef, undef, 10],
		  -slant              => [PASSIVE => undef, undef, 45],
		  -separation         => [PASSIVE => undef, undef, 20],
		  -orientation        => [PASSIVE => undef, undef, 'horizontal'],
		  -colors             => [PASSIVE => undef, undef, [qw/red blue/]],
		  -delay              => [METHOD  => undef, undef, 50],
		  -highlightthickness => [SELF => 'highlightThickness','HighlightThickness',0],
		  -padx               => [PASSIVE => 'padX', 'Pad', 0],
		  -pady               => [PASSIVE => 'padY', 'Pad', 0],
		  -autostart          => [PASSIVE => undef, undef, 1],
		 );

  $c->afterIdle(['_drawPole', $c]);
}

sub _drawPole {
  my $c = shift;

  # calculate the angle, once and for all.
  # and other values.
  $c->{Len}     = $c->cget('-length');
  $c->{Wid}     = $c->cget('-width');
  $c->{Angle}   = $c->cget('-slant') * PI_OVER_180;
  $c->{Inc}     = $c->{Wid} * tan($c->{Angle});
  $c->{Sep}     = $c->cget('-separation');
  $c->{StripeW} = $c->cget('-stripewidth');
  $c->{Col}     = $c->cget('-colors');
  $c->{Ori}     = $c->cget('-orientation');

  # set the correct canvas size.
  my ($w, $h) = $c->{Ori} eq 'horizontal' ? @{$c}{qw/Len Wid/} : @{$c}{qw/Wid Len/};
  my $bw      = $c->cget('-borderwidth') + $c->cget('-highlightthickness');
  my $padx    = $c->cget('-padx');
  my $pady    = $c->cget('-pady');

  my $startX  = $padx + $bw;
  my $startY  = $pady + $bw;

  $w += 2 * $startX;
  $h += 2 * $startY;

  $c->GeometryRequest($w, $h);

  # draw the outline of the pole.
  $c->createRectangle($startX, $startY, $w-$startX-1, $h - $startY-1,
		      -outline => 'black',
		      -tags    => ['BORDER'],
		     );

  # now draw the stripes.
  if ($c->{Ori} eq 'horizontal') {
    my $x     = -($c->{Inc} + $c->{StripeW});
    my $y     = $startY;
    my $color = 0;

    while ($x < $c->{Len}) {
      push @{$c->{Stripes}} =>
	$c->createPolygon($x, $y, $x + $c->{Inc}, $y + $c->{Wid},
			  $x + $c->{Inc} + $c->{StripeW}, $y + $c->{Wid},
			  $x + $c->{StripeW}, $y,
			  -fill => $c->{Col}[$color % @{$c->{Col}}],
			  -tags => ['STRIPE'],
			 );

      $color ++;
      $x += $c->{Sep};
    }

    # make sure the number of poles are a multiple of the number of colors.
    if (my $mod = @{$c->{Stripes}} % @{$c->{Col}}) {

      my $count = $#{$c->{Col}} - $mod;
      my $x     = -($c->{Inc} + $c->{StripeW} + $c->{Sep}) - $count * $c->{Sep};

      my @new;
      for my $i (0 .. $count) {
	push @new =>
	  $c->createPolygon($x, $startY, $x + $c->{Inc}, $startY + $c->{Wid},
			    $x + $c->{Inc} + $c->{StripeW}, $startY + $c->{Wid},
			    $x + $c->{StripeW}, $startY,
			    -fill => $c->{Col}[$color % @{$c->{Col}}],
			    -tags => ['STRIPE'],
			   );

	$color ++;
	$x += $c->{Sep};
      }

      unshift @{$c->{Stripes}} => @new;
    }

  } else {
    # vertical
    my $x     = $startX;
    my $y     = -($c->{Inc} + $c->{StripeW});
    my $color = 0;

    while ($y < $c->{Len}) {
      push @{$c->{Stripes}} =>
	$c->createPolygon($x, $y, $x + $c->{Wid}, $y + $c->{Inc},
			  $x + $c->{Wid}, $y + $c->{Inc} + $c->{StripeW},
			  $x, $y + $c->{StripeW},
			  -fill => $c->{Col}[$color % @{$c->{Col}}],
			  -tags => ['STRIPE'],
			 );

      $color ++;
      $y += $c->{Sep};
    }

    # make sure the number of poles are a multiple of the number of colors.
    if (my $mod = @{$c->{Stripes}} % @{$c->{Col}}) {

      my $count = $#{$c->{Col}} - $mod;
      my $y     = -($c->{Inc} + $c->{StripeW} + $c->{Sep}) - $count * $c->{Sep};
      my @new;
      for my $i (0 .. $count) {
	push @new =>
	  $c->createPolygon($startX, $y, $startX + $c->{Wid}, $y + $c->{Inc},
			    $startX + $c->{Wid}, $y + $c->{Inc} + $c->{StripeW},
			    $startY, $y + $c->{StripeW},
			    -fill => $c->{Col}[$color % @{$c->{Col}}],
			    -tags => ['STRIPE'],
			   );

	$color ++;
	$y += $c->{Sep};
      }

      unshift @{$c->{Stripes}} => @new;
    }
  }

  # tag first stripe
  $c->{First} = $c->{Stripes}[0];

  $c->raise('BORDER');

  $c->start if $c->cget('-autostart');
}

sub _animate {
  my $c = shift;

  # check for any stripes that are outside the visible area
  # and move them to the beginning.

  my @visible = $c->find(overlapping => 0, 0, $c->{Len}, $c->{Wid});
  my %h;
  @h{@{$c->{Stripes}}} = 1;
  delete $h{$_} for @visible;

  for my $id (keys %h) {
    # find how far each stripe is from the end of the pole,
    # and move it the same distance away from the first stripe.

    my @c = $c->coords($id);

    my $dist = $c->{Ori} eq 'horizontal' ? $c[0] - $c->{Len} : $c[1] - $c->{Len};
    next if $dist < 0;   # before the beginning.

    # calculate offset
    my @f      = $c->coords($c->{First});
    my $offset = $c->{Ori} eq 'horizontal' ?
      ($c[0] - $f[0]) + $c->{Sep} :
	($c[1] - $f[1]) + $c->{Sep};

    # move it.
    $c->move($id, $c->{Ori} eq 'horizontal' ? (-$offset, 0) : (0, -$offset));
    $c->{First} = $id;
  }

  # now move everything.
  $c->move(STRIPE => $c->{Ori} eq 'horizontal' ? (1, 0) : (0, 1));
}

sub delay {
  my ($c, $v) = @_;

  if (defined $v) {
    $c->{Delay} = $v;
  }

  if ($c->{Anim}) {
    $c->afterCancel($c->{RepID});
    $c->{RepID} = $c->repeat($c->{Delay}, ['_animate', $c]);
  }

  return $c->{Delay};
}

sub start {
  my $c = shift;

  return if $c->{Anim};

  # now start the animation
  $c->{RepID} = $c->repeat($c->{Delay}, ['_animate', $c]);
  $c->{Anim}  = 1;
}

sub stop {
  my $c = shift;

  return unless $c->{Anim};

  # now stop the animation
  $c->afterCancel($c->{RepID});
  $c->{Anim} = 0;
}

sub tan { sin($_[0]) / cos($_[0])  }

1;

__END__