Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Tk::Animation; |
2 | ||
3 | use vars qw($VERSION); | |
4 | $VERSION = '3.018'; # $Id: //depot/Tk8/Tk/Animation.pm#18 $ | |
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 | return $obj; | |
48 | } | |
49 | ||
50 | sub set_image | |
51 | { | |
52 | my ($obj,$index) = @_; | |
53 | my $frames = $obj->{'_frames_'}; | |
54 | return unless $frames && @$frames; | |
55 | $index = 0 unless $index < @$frames; | |
56 | $obj->copy($frames->[$index]); | |
57 | $obj->{'_frame_index_'} = $index; | |
58 | } | |
59 | ||
60 | sub next_image | |
61 | { | |
62 | my ($obj) = @_; | |
63 | my $frames = $obj->{'_frames_'}; | |
64 | return unless $frames && @$frames; | |
65 | $obj->set_image((($obj->{'_frame_index_'} || 0)+1) % @$frames); | |
66 | } | |
67 | ||
68 | sub start_animation | |
69 | { | |
70 | my ($obj,$period) = @_; | |
71 | my $frames = $obj->{'_frames_'}; | |
72 | return unless $frames && @$frames; | |
73 | my $w = $obj->MainWindow; | |
74 | $obj->stop_animation; | |
75 | $obj->{'_NextId_'} = $w->repeat($period,[$obj,'next_image']); | |
76 | } | |
77 | ||
78 | sub stop_animation | |
79 | { | |
80 | my ($obj) = @_; | |
81 | my $id = delete $obj->{'_NextId_'}; | |
82 | Tk::catch { $id->cancel } if $id; | |
83 | $obj->set_image(0); | |
84 | } | |
85 | ||
86 | 1; | |
87 | __END__ | |
88 | ||
89 | =cut | |
90 | ||
91 | # | |
92 | # This almost works for changing the animation on the fly | |
93 | # but does not resize things correctly | |
94 | # | |
95 | ||
96 | sub gif_sequence | |
97 | { | |
98 | my ($obj,%args) = @_; | |
99 | my $widget = $obj->MainWindow; | |
100 | my @images; | |
101 | local $@; | |
102 | while (1) | |
103 | { | |
104 | my $index = @images; | |
105 | $args{'-format'} = "gif -index $index"; | |
106 | my $img; | |
107 | eval | |
108 | {local $SIG{'__DIE__'}; | |
109 | my $img = $widget->Photo(%args); | |
110 | push(@images,$img); | |
111 | }; | |
112 | last if $@; | |
113 | } | |
114 | if (@images) | |
115 | { | |
116 | delete $obj->{'_frames_'}; | |
117 | $obj->add_frame(@images); | |
118 | $obj->configure(-width => 0, -height => 0); | |
119 | $obj->set_frame(0); | |
120 | } | |
121 | } | |
122 |