home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _3565dfcb0260363d48942d185cd2f2ec < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.7 KB  |  179 lines
  1. package Tk::Animation;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Animation.pm#8 $
  5.  
  6. use Tk::Photo;
  7. use base  qw(Tk::Photo);
  8.  
  9. Construct Tk::Widget 'Animation';
  10.  
  11. sub MainWindow
  12. {
  13.  return shift->{'_MainWIndow_'};
  14. }
  15.  
  16. sub add_frame
  17. {
  18.  my $obj = shift;
  19.  $obj->{'_frames_'} = [] unless exists $obj->{'_frames_'};
  20.  push(@{$obj->{'_frames_'}},@_);
  21. }
  22.  
  23. sub new
  24. {
  25.  my ($class,$widget,%args) = @_;
  26.  my $obj = $class->SUPER::new($widget,%args);
  27.  $obj->{'_MainWIndow_'} = $widget->MainWindow;
  28.  if ($args{'-format'} eq 'gif')
  29.   {
  30.    my @images;
  31.    local $@;
  32.    while (1)
  33.     {
  34.      my $index = @images;
  35.      $args{'-format'} = "gif -index $index";
  36.      my $img;
  37.      eval {local $SIG{'__DIE__'};  $img = $class->SUPER::new($widget,%args) };
  38.      last if $@;
  39.      push(@images,$img);
  40.     }
  41.    if (@images > 1)
  42.     {
  43.      $obj->add_frame(@images);
  44.      $obj->{'_frame_index_'}  = 0;
  45.     }
  46.   }
  47.  $obj->set_image( 0 );
  48.  $obj->{_delta_} = 1;
  49.  $obj->{_blank_} = 0;
  50.  return $obj;
  51. }
  52.  
  53. sub fast_forward {
  54.  
  55.     my( $self, $delta) = @_;
  56.  
  57.     $self->{_delta_} = $delta;
  58.     if( not exists $self->{_playing_} ) {
  59.     my $playing = exists $self->{'_NextId_'};
  60.     $self->{_playing_} = $playing;
  61.     $self->resume_animation if not $playing;
  62.     } else {
  63.     my $playing = delete $self->{_playing_};
  64.     $self->pause_animation if not $playing;
  65.     }
  66.  
  67. } # end fast_forward
  68.  
  69. *fast_reverse = \&fast_forward;
  70.  
  71. sub frame_count {
  72.     my $frames = shift->{'_frames_'};
  73.     return -1 unless $frames;
  74.     return @$frames;
  75. }
  76.  
  77. sub blank {
  78.     my( $self, $blank ) = @_;
  79.     $blank = 1 if not defined $blank;
  80.     $self->{_blank_} = $blank;
  81.     $blank;
  82. }
  83.  
  84. sub set_image
  85. {
  86.  my ($obj,$index)  = @_;
  87.  my $frames = $obj->{'_frames_'};
  88.  return unless $frames && @$frames;
  89.  $index = 0 unless $index < @$frames;
  90.  $obj->blank if $obj->{_blank_};  # helps some make others worse
  91.  $obj->copy($frames->[$index]);
  92.  $obj->{'_frame_index_'} = $index;
  93. }
  94.  
  95. sub next_image
  96. {
  97.  my ($obj, $delta)  = @_;
  98.  $delta = $obj->{_delta_} unless $delta;
  99.  my $frames = $obj->{'_frames_'};
  100.  return unless $frames && @$frames;
  101.  $obj->set_image((($obj->{'_frame_index_'} || 0) + $delta) % @$frames);
  102. }
  103.  
  104. sub prev_image { shift->next_image( -1 ) }
  105.  
  106. sub pause_animation { 
  107.     my $self = shift;
  108.     my $id = delete $self->{'_NextId_'};
  109.     Tk::catch { $id->cancel } if $id;
  110. }
  111.  
  112. sub resume_animation {
  113.     my( $self, $period ) = @_;
  114.     if( not defined $self->{'_period_'} ) {
  115.     $self->{'_period_'} = defined( $period ) ? $period : 100;
  116.     }
  117.     $period = $self->{'_period_'};
  118.     my $w = $self->MainWindow;
  119.     $self->{'_NextId_'} = $w->repeat( $period => [ $self => 'next_image' ] );
  120. }
  121.  
  122. sub start_animation
  123. {
  124.  my ($obj,$period) = @_;
  125.  $period ||= 100;
  126.  my $frames = $obj->{'_frames_'};
  127.  return unless $frames && @$frames;
  128.  my $w = $obj->MainWindow;
  129.  $obj->stop_animation;
  130.  $obj->{'_period_'} = $period;
  131.  $obj->{'_NextId_'} = $w->repeat($period,[$obj,'next_image']);
  132. }
  133.  
  134. sub stop_animation
  135. {
  136.  my ($obj) = @_;
  137.  my $id = delete $obj->{'_NextId_'};
  138.  Tk::catch { $id->cancel } if $id;
  139.  $obj->set_image(0);
  140. }
  141.  
  142. 1;
  143. __END__
  144.  
  145. =cut
  146.  
  147. #
  148. # This almost works for changing the animation on the fly
  149. # but does not resize things correctly
  150. #
  151.  
  152. sub gif_sequence
  153. {
  154.  my ($obj,%args) = @_;
  155.  my $widget = $obj->MainWindow;
  156.  my @images;
  157.  local $@;
  158.  while (1)
  159.   {
  160.    my $index = @images;
  161.    $args{'-format'} = "gif -index $index";
  162.    my $img;
  163.    eval
  164.     {local $SIG{'__DIE__'};
  165.      my $img = $widget->Photo(%args);
  166.      push(@images,$img);
  167.     };
  168.    last if $@;
  169.   }
  170.  if (@images)
  171.   {
  172.    delete $obj->{'_frames_'};
  173.    $obj->add_frame(@images);
  174.    $obj->configure(-width => 0, -height => 0);
  175.    $obj->set_frame(0);
  176.   }
  177. }
  178.  
  179.