Tk image resizer

[Discipulus]

Hello monks,

was a rainy saturday and i need some resized images for a new website (a Dancer2 one).. but i'm digressing.
This script globs all jpg images in the current directory and creates one or more resized ones with new names. EXIF data are cleaned in new images whilst you can view some of them, for your convenience, in the preview of the original image.

Only argouments accepted are string in the form width x heigth x descr as in 1204x768xBig
You can specify more then one format passing, for example: 1204x768xBig 640x480xMed 200x100xMin
The description in the string is optional: if not present is used the given ratio: 1204x768 wil be appended to the file name given.

Using Image::Resize the ratio is maintained for the original photo, ie only the width will be used, while the height will be adjusted as needed.

The code is redundant and somehow ugly, but Perl does not complains about this..

HtH
L*

#!/usr/bin/perl
use warnings;
use strict;
use MIME::Base64;
use Image::Resize;
use Tk;
use Tk::JPEG;
use Image::EXIF;



die "usage: $0 250x169xmin 768x250xmed\n
\tEg Width x High x Descr.
Third element can be omitted (the description) and
Width x High string will be used.\n\n" unless  (defined $ARGV[0] and $
+ARGV[0] =~ /\d+x\d+/);

my @files = glob('*.jpg');
   print "\nFound ".scalar @files." files\n\n";
exit if  scalar @files == 0;
my @size_descr = map { [split 'x', $_] }@ARGV;
my $x = 640; my $y = 480;
my $mx = $x; my $my = $y + 200;

my $mw    = new MainWindow ();
$mw -> geometry ($mx.'x'.$my);
$mw->optionAdd('*font', 'Courier 12');


my $c  = $mw->Canvas;
$c->pack(-expand => 1, -fill => 'both');
my $cur_file = shift @files;
    print "Considering $cur_file\n";
my $exif = &get_exif($cur_file);

my $gd = &phres($cur_file,$x,$y);
my $image = $c->Photo( -data=>  MIME::Base64::encode( $gd ));
$c->createImage($x/2 , $y/2, -image => $image);
my $label_exif_txt = "Exif info\n".
                     "size: ".($$exif{width} ? $$exif{width} : 'undef'
+ ).
                     " x ".( $$exif{height} ? $$exif{height} :'undef' 
+)."\n".
                     "date: ". ($$exif{date} ? $$exif{date} : 'undef')
+;
my $label_exif =$mw->Label( -justify  => 'left', -background => 'black
+',-foreground => 'chartreuse1',
                            -textvariable => \$label_exif_txt )->pack;
my $label =$mw->Label(-text=> 'Insert a new name for the photo above.'
+."\n".
                      'The name will be added with the infix specified
+ in command line'."\n".
                      'Then hit <Return> or the button below.')->pack(
+) ;
my $button_skip = $mw->Button(-borderwidth => 2,-relief => 'solid',-te
+xt => 'Skip this image', -command => \&next_pic)->pack;
my $newname;
my $entry = $mw->Entry( -width => 100,-borderwidth => 4, -textvariable
+ => \$newname)->pack;
   $entry->bind('<Return>' => \&elaborate);
   $entry->focus;
my $button = $mw->Button(-borderwidth => 2,-relief => 'solid',-text =>
+ 'Create resized and renamed images', -command => \&elaborate)->pack;




$mw->MainLoop;
######################################################################
+##########
sub next_pic {
    $cur_file = shift @files;
    unless ($cur_file){
        print "\nThe End\n";
        $c->destroy;
        $label->destroy;
        $label_exif->destroy;
        $button_skip->destroy;
        $entry->destroy;
        $button->destroy;
        $mw->Label(-text=>"The End\nwill happen in 3 seconds..")->pack
+() ;
        $mw->update;
        sleep 3;
        exit 0;
    }
    print "Considering $cur_file\n";
    $gd = &phres($cur_file,$x,$y);
    my $enc =  MIME::Base64::encode($gd);

    $image->blank;
    $image= $c->Photo( -data=>$enc);
    $c->createImage($x/2 , $y/2,-image => $image );
      $exif = &get_exif($cur_file);
      $label_exif_txt = "Exif info\n".
                            "size: ".($$exif{width} ? $$exif{width} : 
+'undef' ).
                            " x ".( $$exif{height} ? $$exif{height} :'
+undef' )."\n".
                            "date: ". ($$exif{date} ? $$exif{date} : '
+undef');
    $entry->delete(0, 'end');
    $mw->update;
    select(undef, undef, undef, .1);
}
######################################################################
+##########
sub elaborate{
    $newname = $entry->get();
    #########################################
    foreach my $res ( @size_descr ) {
            my $gd = &phres($cur_file,$$res[0], $$res[1]);
            &write_resized ($newname."_".(defined $$res[2] ? $$res[2] 
+: "$$res[0]x$$res[1]" )."_".'.jpg',$gd);
    }
    #########################################
    &next_pic;
}
######################################################################
+##########
sub phres {
    my ($file, $x, $y) = @_;
    my    $image_orig = Image::Resize->new($file, $x, $y);
    my    $gd = $image_orig->resize($x, $y);
    return $gd->jpeg();
}
######################################################################
+##########
sub write_resized{
    my ($name, $data) = @_;
    open(FH, '>', $name) or warn "Cannot write to $name! ";
    binmode FH;
    print FH $data;
    close(FH);
    print "\tOK: wrote $name\n";
}
######################################################################
+##########
sub get_exif {
    my $file = shift;
    my $exif = Image::EXIF->new($file);
    my %exif_img = %{$exif->get_image_info()|| {} };
    my %exif = (
          width => $exif_img{'Image Width'},
          height=> $exif_img{'Image Height'},
          date  => $exif_img{'Image Created'},
    );
    return \%exif;
}
__END__

[RonW]

Nice tool

Question: You say: Using Image::Resize the ratio is maintained for the original photo, ie only the width will be used, while the height will be adjusted as needed. If height is not used, why ask for it? Also, maybe there's a way to force resize to use it. If the height parameter is optional, then specifying it would be a way to indicate desire to force its use.

[Discipulus]

this was born as quick hack, as always..
I think is simpler to remember that you need to pass a width X height x infix then others things. You can easyly modify the code to change both dimension if it is what you want (from module documentation):


resize($width, $height, $constraint);
Returns a GD::Image object for the new, resized image. Original image 
+is not modified. This lets you create multiple thumbnails of an image
+ using the same Image::Resize object.

First two arguments are required, which define new image dimensions. B
+y default resize() retains image proportions while resizing. This is 
+always what you expect to happen. In case you don't care about retain
+ing image proportions, pass 0 as the third argument to resize().


L*