From 9fc19ef8e2dcd8bcf6a1d034b95c1de2b88e485c Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 17 Feb 2011 15:05:13 +0000 Subject: New tlperl part II git-svn-id: svn://tug.org/texlive/trunk@21424 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/Tk/Animation.pm | 230 ++++++++++++++++++++++++++++++++ 1 file changed, 230 insertions(+) create mode 100644 Master/tlpkg/tlperl/lib/Tk/Animation.pm (limited to 'Master/tlpkg/tlperl/lib/Tk/Animation.pm') diff --git a/Master/tlpkg/tlperl/lib/Tk/Animation.pm b/Master/tlpkg/tlperl/lib/Tk/Animation.pm new file mode 100644 index 00000000000..24cfacb4a7c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Animation.pm @@ -0,0 +1,230 @@ +package Tk::Animation; + +use vars qw($VERSION); +$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Animation.pm#8 $ + +use Tk::Photo; +use base qw(Tk::Photo); + +Construct Tk::Widget 'Animation'; + +sub MainWindow +{ + return shift->{'_MainWIndow_'}; +} + +sub add_frame +{ + my $obj = shift; + $obj->{'_frames_'} = [] unless exists $obj->{'_frames_'}; + push(@{$obj->{'_frames_'}},@_); +} + +sub new +{ + my ($class,$widget,%args) = @_; + my $obj = $class->SUPER::new($widget,%args); + $obj->{'_MainWIndow_'} = $widget->MainWindow; + if ($args{'-format'} eq 'gif') + { + my @images; + local $@; + while (1) + { + my $index = @images; + $args{'-format'} = "gif -index $index"; + my $img; + eval {local $SIG{'__DIE__'}; $img = $class->SUPER::new($widget,%args) }; + last if $@; + push(@images,$img); + } + if (@images > 1) + { + $obj->add_frame(@images); + $obj->{'_frame_index_'} = 0; + } + } + $obj->set_image( 0 ); + $obj->_get_gif_info; + return $obj; +} + +sub fast_forward { + + my( $self, $delta) = @_; + + $self->{_delta_} = $delta; + if( not exists $self->{_playing_} ) { + my $playing = exists $self->{'_NextId_'}; + $self->{_playing_} = $playing; + $self->resume_animation if not $playing; + } else { + my $playing = delete $self->{_playing_}; + $self->pause_animation if not $playing; + } + +} # end fast_forward + +*fast_reverse = \&fast_forward; + +sub frame_count { + my $frames = shift->{'_frames_'}; + return -1 unless $frames; + return @$frames; +} + +sub set_disposal_method { + my( $self, $blank ) = @_; + $blank = 1 if not defined $blank; + $self->{_blank_} = $blank; + $blank; +} + +sub set_image +{ + my ($obj,$index) = @_; + my $frames = $obj->{'_frames_'}; + return unless $frames && @$frames; + $index = 0 unless $index < @$frames; + $obj->blank if $obj->{_blank_}; # helps some make others worse + $obj->copy($frames->[$index]); + $obj->{'_frame_index_'} = $index; +} + +sub next_image +{ + my ($obj, $delta) = @_; + $obj->_next_image($delta); +} + +sub _next_image +{ + my ($obj, $delta, $in_animation) = @_; + $delta = $obj->{_delta_} unless $delta; + my $frames = $obj->{'_frames_'}; + return unless $frames && @$frames; + my $next_index = (($obj->{'_frame_index_'} || 0) + $delta); + if ($next_index > @$frames && $in_animation && $obj->{'_loop_'} ne 'forever') + { + return 0; # signal to stop animation + } + $next_index %= @$frames; + $obj->set_image($next_index); + 1; +} + +sub prev_image { shift->next_image( -1 ) } + +sub next_image_in_animation +{ + my ($obj, $delta) = @_; + my $continue = $obj->_next_image($delta, 1); + if (!$continue && $self->{'_NextId_'}) + { + $obj->pause_animation; + } +} + +sub pause_animation { + my $self = shift; + my $id = delete $self->{'_NextId_'}; + Tk::catch { $id->cancel } if $id; +} + +sub resume_animation { + my( $self, $period ) = @_; + if( not defined $self->{'_period_'} ) { + $self->{'_period_'} = defined( $period ) ? $period : 100; + } + $period = $self->{'_period_'}; + my $w = $self->MainWindow; + $self->{'_NextId_'} = $w->repeat( $period => [ $self => 'next_image_in_animation' ] ); +} + +sub start_animation +{ + my ($obj,$period) = @_; + my $frames = $obj->{'_frames_'}; + return unless $frames && @$frames; + my $w = $obj->MainWindow; + $obj->stop_animation; + $obj->{'_period_'} = $period if $period; + $obj->{'_NextId_'} = $w->repeat($obj->{'_period_'},[$obj,'next_image_in_animation']); +} + +sub stop_animation +{ + my ($obj) = @_; + my $id = delete $obj->{'_NextId_'}; + Tk::catch { $id->cancel } if $id; + $obj->set_image(0); +} + +sub _get_gif_info +{ + my ($obj) = @_; + my $info; + if (defined(my $file = $obj->cget(-file)) && eval { require Image::Info; 1; }) + { + $info = Image::Info::image_info($file); + } + elsif (defined(my $data = $obj->cget(-data))) + { + if ($data =~ m{^GIF8} && eval { require Image::Info; 1; }) + { + $info = Image::Info::image_info(\$data); + } + elsif (eval { require Image::Info; require MIME::Base64; 1; }) + { + $data = MIME::Base64::decode_base64($data); + $info = Image::Info::image_info(\$data); + } + } + if ($info) + { + $obj->{'_blank_'} = $info->{DisposalMethod} == 2 || $info->{DisposalMethod} == 3; + $obj->{'_period_'} = $info->{Delay}*1000 if defined $info->{Delay}; + $obj->{'_loop_'} = $info->{GIF_Loop}; + } + $obj->{'_blank_'} = 0 if !defined $obj->{'_blank_'}; + $obj->{'_period_'} = 100 if !defined $obj->{'_period_'}; + $obj->{'_loop_'} = 'forever' if !defined $obj->{'_loop_'}; + $obj->{'_delta_'} = 1; +} + +1; + +__END__ + +# +# This almost works for changing the animation on the fly +# but does not resize things correctly +# + +sub gif_sequence +{ + my ($obj,%args) = @_; + my $widget = $obj->MainWindow; + my @images; + local $@; + while (1) + { + my $index = @images; + $args{'-format'} = "gif -index $index"; + my $img; + eval + {local $SIG{'__DIE__'}; + my $img = $widget->Photo(%args); + push(@images,$img); + }; + last if $@; + } + if (@images) + { + delete $obj->{'_frames_'}; + $obj->add_frame(@images); + $obj->configure(-width => 0, -height => 0); + $obj->set_frame(0); + } +} + -- cgit v1.2.3