#!/usr/bin/perl

use strict;
use warnings;
use Tk;
use Tk::Animation;
use Tk::Photo;

my $scale;
my $haupt = new MainWindow;
my $img = $haupt->Animation('-format' => 'gif', -file => './icons/archiv.gif');
my $image = $haupt->Photo('-format' => 'gif', -file => './icons/top.gif');
my $image2 = $haupt->Photo('-format' => 'gif', -file => './icons/edit.gif');
$img->add_frame($image);
$img->add_frame($image2);
my $label = $haupt->Label(-image=>$img)->pack;
$img->add_label($label);
$img->blank(1);

$scale = $haupt->Scale(-from => 0, -to => $#{$img->{'_frames_'}}, 
                             -orient => "horizontal", 
                             -command =>sub { $img->set_image( $scale->get ); } )->pack();

MainLoop();

sub new{
   my ($class,$widget,%args) = @_;
   my $obj = $class->SUPER::new($widget,%args);
   $obj->{'_MainWIndow_'} = $widget->MainWindow;
   if ($args{'-format'} eq 'gif'){
     my @images;
     $obj->add_frame($class->SUPER::new($widget,%args));
   }
   $obj->set_image( 0 );
   $obj->{_delta_} = 1;
   $obj->{_blank_} = 0;
   return $obj;
}

sub set_image{
   my ($obj,$index)  = @_;
   my $frames = $obj->{'_frames_'};
   return unless $frames && scalar(@$frames)>0;
   $obj->clear_label();
   $index = 0 unless $index < @$frames;
   $obj->blank if $obj->{_blank_};  # helps some make others worse
   $obj->copy($frames->[$index]);
   $obj->{label}->configure(-image => $frames->[$index]) if(defined $obj->{label});
   $obj->{'_frame_index_'} = $index;
}

sub add_label{
   my ($obj,$label) = @_;
   $obj->{label} = $label if defined $label;
}

sub clear_label{
   my ($obj) = @_;
   if(defined $obj->{label}){
     $obj->{label}->configure(-image => '');
   }
}