#no leak tk-memtest07.pl
#!/usr/bin/perl
use warnings;
use strict;

use Tk;
use Tk::JPEG;
use Tk::Pane;

use File::Spec;

use GD;
use MIME::Base64;

my $glob = $ARGV[0]||'./*.jpg';

my @files;
&build_list($glob);


###########################################################
my $mw = new MainWindow ();
   $mw->geometry("100x50+0+0");

$mw->Button(-text => "nex picture",
                  -command => sub{
                  #for (1..100){  # uncomment this line to test 100 pics
                                  &next_pic;
                  #}              # uncomment this line to test 100 pics
                              }
                  )->pack();

my $phwin = $mw->Toplevel();

# default empty image
# see http://www.perlmonks.org/?node_id=535837
my $tk_ph_image = $phwin->Photo(-file => '' ) or die $!;
my $photo_label;

# fill mainframe with default screen
setup_pane();
next_pic();
$mw->MainLoop;

################################################################################
sub next_pic {
   my $pic_file = shift @files;
   print "processing [$pic_file]\n";

   # http://search.cpan.org/~srezic/Tk-804.033/pod/Image.pod
   # It's necessary to use the "delete" method to delete an image object and
   # free memory associated with it. Just using a lexical variable for storing
   # the image object and letting the variable to go out of scope or setting to
   # undef is not sufficient.
   #
   # $tk_ph_image is a Tk::Photo object
   $tk_ph_image->delete if $tk_ph_image->blank;

   # load original pic file in GD
   my $gd_image = GD::Image->new($pic_file);
   # find out smaller dimensions used to create the resized image
   my $small_w = int($gd_image->width * 0.3);
   my $small_h = int($gd_image->height * 0.3);
   # create the resized but still empty GD image
   my $resized = GD::Image->new($small_w,$small_h);
   # copy from source into resized on
      $resized->copyResized($gd_image,0,0,0,0,
              $small_w,
              $small_h,
              $gd_image->width,
              $gd_image->height);
   # free the original GD image
   $gd_image = undef;
   # configure the existing (still empty) Tk::Photo object
   # i found somewhere the '-file => undef' part but I do not remember where..
   $tk_ph_image->configure( -file => undef,
                            -data => MIME::Base64::encode($resized->jpeg())
   );
   # configure the Tk::Label to use the Tk::Photo as image
   $photo_label->configure(-image => $tk_ph_image );

   # system 'tasklist | grep perl'; # debug memory usage

   # see also:
   # http://www.perlmonks.org/?node_id=403597
   # http://www.perlmonks.org/?node_id=537705
}
#############################################################
# see http://www.perlmonks.org/?node_id=535837
sub setup_pane{

  my $pane = $phwin->Scrolled('Pane', Name => 'Main Display',
               -width => 400,
               -height =>400,
               -background => 'black',
               -scrollbars => 'osoe',
               -sticky => 'n',
              )->pack(-side => "left", -anchor => "n",
                      -fill=>'both',-expand=>1);

  # the global!
  $photo_label = $pane->Label(-image => $tk_ph_image,
                      -background =>'black'
                     )->pack(-side => 'top',
                       -anchor => 'n',
                       -fill => 'both',
                       -expand => 1,
                      );

}
################################################################################
sub build_list{
    my $glob=shift;
    print "received [$glob]\n";
    map {
          push @files,File::Spec->file_name_is_absolute($_) ?
                        $_ : File::Spec->rel2abs($_);
    } glob($glob);
    print "$_\n" for @files;
}