summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Animation.pm
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 15:05:13 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 15:05:13 +0000
commit9fc19ef8e2dcd8bcf6a1d034b95c1de2b88e485c (patch)
treeee28de37fe0de6137d535fee2e64ecafaffefb91 /Master/tlpkg/tlperl/lib/Tk/Animation.pm
parent73b942cfb4ccf168f9c2b7f20a289b06f1f54a4b (diff)
New tlperl part II
git-svn-id: svn://tug.org/texlive/trunk@21424 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Animation.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Animation.pm230
1 files changed, 230 insertions, 0 deletions
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);
+ }
+}
+