"Fossies" - the Fresh Open Source Software Archive

Member "Tk-804.036/Tk/Animation.pm" (15 Nov 2013, 5025 Bytes) of package /linux/misc/Tk-804.036.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Animation.pm" see the Fossies "Dox" file reference documentation.

    1 package Tk::Animation;
    2 
    3 use vars qw($VERSION);
    4 $VERSION = '4.008'; # $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->_get_gif_info;
   49  return $obj;
   50 }
   51 
   52 sub fast_forward {
   53 
   54     my( $self, $delta) = @_;
   55 
   56     $self->{_delta_} = $delta;
   57     if( not exists $self->{_playing_} ) {
   58     my $playing = exists $self->{'_NextId_'};
   59     $self->{_playing_} = $playing;
   60     $self->resume_animation if not $playing;
   61     } else {
   62     my $playing = delete $self->{_playing_};
   63     $self->pause_animation if not $playing;
   64     }
   65 
   66 } # end fast_forward
   67 
   68 *fast_reverse = \&fast_forward;
   69 
   70 sub frame_count {
   71     my $frames = shift->{'_frames_'};
   72     return -1 unless $frames;
   73     return @$frames;
   74 }
   75 
   76 sub set_disposal_method {
   77     my( $self, $blank ) = @_;
   78     $blank = 1 if not defined $blank;
   79     $self->{_blank_} = $blank;
   80     $blank;
   81 }
   82 
   83 sub set_image
   84 {
   85  my ($obj,$index)  = @_;
   86  my $frames = $obj->{'_frames_'};
   87  return unless $frames && @$frames;
   88  $index = 0 unless $index < @$frames;
   89  $obj->blank if $obj->{_blank_};  # helps some make others worse
   90  $obj->copy($frames->[$index]);
   91  $obj->{'_frame_index_'} = $index;
   92 }
   93 
   94 sub next_image
   95 {
   96  my ($obj, $delta)  = @_;
   97  $obj->_next_image($delta);
   98 }
   99 
  100 sub _next_image
  101 {
  102  my ($obj, $delta, $in_animation)  = @_;
  103  $delta = $obj->{_delta_} unless $delta;
  104  my $frames = $obj->{'_frames_'};
  105  return unless $frames && @$frames;
  106  my $next_index = (($obj->{'_frame_index_'} || 0) + $delta);
  107  if ($next_index > @$frames && $in_animation && $obj->{'_loop_'} ne 'forever')
  108   {
  109    return 0; # signal to stop animation
  110   }
  111  $next_index %= @$frames;
  112  $obj->set_image($next_index);
  113  1;
  114 }
  115 
  116 sub prev_image { shift->next_image( -1 ) }
  117 
  118 sub next_image_in_animation
  119 {
  120  my ($obj, $delta) = @_;
  121  my $continue = $obj->_next_image($delta, 1);
  122  if (!$continue && $self->{'_NextId_'})
  123   {
  124    $obj->pause_animation;
  125   }
  126 }
  127 
  128 sub pause_animation { 
  129     my $self = shift;
  130     my $id = delete $self->{'_NextId_'};
  131     Tk::catch { $id->cancel } if $id;
  132 }
  133 
  134 sub resume_animation {
  135     my( $self, $period ) = @_;
  136     if( not defined $self->{'_period_'} ) {
  137     $self->{'_period_'} = defined( $period ) ? $period : 100;
  138     }
  139     $period = $self->{'_period_'};
  140     my $w = $self->MainWindow;
  141     $self->{'_NextId_'} = $w->repeat( $period => [ $self => 'next_image_in_animation' ] );
  142 }
  143 
  144 sub start_animation
  145 {
  146  my ($obj,$period) = @_;
  147  my $frames = $obj->{'_frames_'};
  148  return unless $frames && @$frames;
  149  my $w = $obj->MainWindow;
  150  $obj->stop_animation;
  151  $obj->{'_period_'} = $period if $period;
  152  $obj->{'_NextId_'} = $w->repeat($obj->{'_period_'},[$obj,'next_image_in_animation']);
  153 }
  154 
  155 sub stop_animation
  156 {
  157  my ($obj) = @_;
  158  my $id = delete $obj->{'_NextId_'};
  159  Tk::catch { $id->cancel } if $id;
  160  $obj->set_image(0);
  161 }
  162 
  163 sub _get_gif_info
  164 {
  165  my ($obj) = @_;
  166  my $info;
  167  if (defined(my $file = $obj->cget(-file)) && eval { require Image::Info; 1; })
  168   {
  169    $info = Image::Info::image_info($file);
  170   }
  171  elsif (defined(my $data = $obj->cget(-data)))
  172   {
  173    if ($data =~ m{^GIF8} && eval { require Image::Info; 1; })
  174     {
  175      $info = Image::Info::image_info(\$data);
  176     }
  177    elsif (eval { require Image::Info; require MIME::Base64; 1; })
  178     {
  179      $data = MIME::Base64::decode_base64($data);
  180      $info = Image::Info::image_info(\$data);
  181     }
  182   }
  183  if ($info)
  184   {
  185    $obj->{'_blank_'} = $info->{DisposalMethod} == 2 || $info->{DisposalMethod} == 3;
  186    $obj->{'_period_'} = $info->{Delay}*1000 if defined $info->{Delay};
  187    $obj->{'_loop_'} = $info->{GIF_Loop};
  188   }
  189  $obj->{'_blank_'} = 0 if !defined $obj->{'_blank_'};
  190  $obj->{'_period_'} = 100 if !defined $obj->{'_period_'};
  191  $obj->{'_loop_'} = 'forever' if !defined $obj->{'_loop_'};
  192  $obj->{'_delta_'} = 1;
  193 }
  194 
  195 1;
  196 
  197 __END__
  198 
  199 #
  200 # This almost works for changing the animation on the fly
  201 # but does not resize things correctly
  202 #
  203 
  204 sub gif_sequence
  205 {
  206  my ($obj,%args) = @_;
  207  my $widget = $obj->MainWindow;
  208  my @images;
  209  local $@;
  210  while (1)
  211   {
  212    my $index = @images;
  213    $args{'-format'} = "gif -index $index";
  214    my $img;
  215    eval
  216     {local $SIG{'__DIE__'};
  217      my $img = $widget->Photo(%args);
  218      push(@images,$img);
  219     };
  220    last if $@;
  221   }
  222  if (@images)
  223   {
  224    delete $obj->{'_frames_'};
  225    $obj->add_frame(@images);
  226    $obj->configure(-width => 0, -height => 0);
  227    $obj->set_frame(0);
  228   }
  229 }
  230