view release on metacpan or  search on metacpan

BarberPole.pm  view on Meta::CPAN

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'],
		     );