home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.8.3.809-MSWin32-x86.msi / _3565dfcb0260363d48942d185cd2f2ec < prev    next >
Encoding:
Text File  |  2004-02-02  |  2.4 KB  |  124 lines
  1. package Tk::Animation;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = '3.020'; # $Id: //depot/Tk8/Tk/Animation.pm#20 $
  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.  return $obj;
  48. }
  49.  
  50. sub set_image
  51. {
  52.  my ($obj,$index)  = @_;
  53.  my $frames = $obj->{'_frames_'};
  54.  return unless $frames && @$frames;
  55.  $index = 0 unless $index < @$frames;
  56.  $obj->blank if 0;  # helps some make others worse
  57.  $obj->copy($frames->[$index]);
  58.  $obj->{'_frame_index_'} = $index;
  59. }
  60.  
  61. sub next_image
  62. {
  63.  my ($obj)  = @_;
  64.  my $frames = $obj->{'_frames_'};
  65.  return unless $frames && @$frames;
  66.  $obj->set_image((($obj->{'_frame_index_'} || 0)+1) % @$frames);
  67. }
  68.  
  69. sub start_animation
  70. {
  71.  my ($obj,$period) = @_;
  72.  my $frames = $obj->{'_frames_'};
  73.  return unless $frames && @$frames;
  74.  my $w = $obj->MainWindow;
  75.  $obj->stop_animation;
  76.  $obj->{'_NextId_'} = $w->repeat($period,[$obj,'next_image']);
  77. }
  78.  
  79. sub stop_animation
  80. {
  81.  my ($obj) = @_;
  82.  my $id = delete $obj->{'_NextId_'};
  83.  Tk::catch { $id->cancel } if $id;
  84.  $obj->set_image(0);
  85. }
  86.  
  87. 1;
  88. __END__
  89.  
  90. =cut
  91.  
  92. #
  93. # This almost works for changing the animation on the fly
  94. # but does not resize things correctly
  95. #
  96.  
  97. sub gif_sequence
  98. {
  99.  my ($obj,%args) = @_;
  100.  my $widget = $obj->MainWindow;
  101.  my @images;
  102.  local $@;
  103.  while (1)
  104.   {
  105.    my $index = @images;
  106.    $args{'-format'} = "gif -index $index";
  107.    my $img;
  108.    eval
  109.     {local $SIG{'__DIE__'};
  110.      my $img = $widget->Photo(%args);
  111.      push(@images,$img);
  112.     };
  113.    last if $@;
  114.   }
  115.  if (@images)
  116.   {
  117.    delete $obj->{'_frames_'};
  118.    $obj->add_frame(@images);
  119.    $obj->configure(-width => 0, -height => 0);
  120.    $obj->set_frame(0);
  121.   }
  122. }
  123.  
  124.