1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
package Tk::Animation;
use vars qw($VERSION);
$VERSION = '3.020'; # $Id: //depot/Tk8/Tk/Animation.pm#20 $
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;
}
}
return $obj;
}
sub set_image
{
my ($obj,$index) = @_;
my $frames = $obj->{'_frames_'};
return unless $frames && @$frames;
$index = 0 unless $index < @$frames;
$obj->blank if 0; # helps some make others worse
$obj->copy($frames->[$index]);
$obj->{'_frame_index_'} = $index;
}
sub next_image
{
my ($obj) = @_;
my $frames = $obj->{'_frames_'};
return unless $frames && @$frames;
$obj->set_image((($obj->{'_frame_index_'} || 0)+1) % @$frames);
}
sub start_animation
{
my ($obj,$period) = @_;
my $frames = $obj->{'_frames_'};
return unless $frames && @$frames;
my $w = $obj->MainWindow;
$obj->stop_animation;
$obj->{'_NextId_'} = $w->repeat($period,[$obj,'next_image']);
}
sub stop_animation
{
my ($obj) = @_;
my $id = delete $obj->{'_NextId_'};
Tk::catch { $id->cancel } if $id;
$obj->set_image(0);
}
1;
__END__
=cut
#
# 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);
}
}
|
