"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