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.
The description in the string is optional: if not present is used the given ratio:
wil be appended to the file name given.
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..
#!/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__
