#!/usr/bin/perl # image_rescale doom@kzsu.stanford.edu # 22 Jun 2004 =head1 NAME image_rescale =head1 SYNOPSIS cd image_rescale cd image_rescale -t0.1 # Trim the edges 10% before rescaling. cd /home/doom/End/Dust/Junk/Incoming/ image_find_oversized > ~/tmp/incoming_oversized.lst image_rescale -D -l ~/tmp/incoming_oversized.lst system( "image_rescale -s $source -a $archive -h $height_limit -w $width_limit -l $image_list"; ); =head1 OPTIONS =over =item -h Allows height of envelope to rescale to to be passed in explicitly. (default: screen height less 30) =item -w Allows width of envelope to rescale to to be passed in explicitly. (default: screen width) =item -s Location of tree of images being worked on. Subdirectories of this root are preserved when automatically archiving the original. (default: JUNK_INCOMING or else JUNK_PILE both from Junk::Et) =item -a The archive location, where a parallel tree of originals will be automatically copied to before rescaling. (default: JUNK_PRE_RESCALE from Junk::Et) =item -t - "trim" - crop image by given fraction (e.g. 0.1 = 10% trim) this is done before re-sizing. Default: zero, i.e. do not trim. =item -l process images from given list file, rather than just working on the current directory. =item -D switch, turns on debugging =item -V switch, turns on verbose output (currently defaults to on, though) =item -Q switch, quiet mode tells it to shut up (overrides "debug" or "verbose") =item -q "quality" setting for new jpegs, (0-9) (defaults to 8) =item -n "nice" flag. Number of seconds to sleep between rescales: defaults to 5 =back =head1 DESCRIPTION image_rescale - rescale jpegs to fit on the screen, and save under a new name. Some insanely large jpegs come in off of the net some times. This script crunches through a bunch of images, finding ones that are too large to display at the current screen resolution, it archives a copy of the original in a standard location (defined in Junk::Et), and re-scales the original, saving it in place. With the -t option, it's possible to tell it to trim some fraction from the edges before doing the re-scale (i.e. to do a fixed-scale auto-crop). Images that don't need to be re-scaled should remain unaffected. By default, it looks at all images in the current directory. You can get it to look at all files in a list of files with the -l option. (Use this with image_find_oversized a tool to scan through the tree of stashed images looking for excessively large ones.) Currently, the $archive tree goes here: /home/doom/End/Dust/HiddenJunk/Junk-collection-originals/Pre-rescaled See Junk::Et: JUNK_PRE_RESCALE The archived originals are stashed using the portion of the path that occurs after one of these standard locations (again, see Junk::Et): /home/doom/End/Dust/Junk/Incoming /home/doom/End/Dust/Junk/ =cut use warnings; use strict; $|=1; use Cwd; use Junk::Et qw(JUNK_PILE JUNK_INCOMING JUNK_PRE_RESCALE); # TikiMageF; # Combining forces of Tk/perl and ImageMagick (function oriented) use Tk; use Tk::JPEG; ### Alternate: ### use Tk::JPEG::Lite; use Image::Magick; use MIME::Base64; ### use MiscUtils; # imports mkdirs use File::Path; # imports mkpath, which looks better. use File::Copy; use File::Basename; # imports dirname use File::Preserve; use File::ExtensionFilter; use File::FullNameLists; use Getopt::Std; our (%opt, $VERBOSE, $DEBUG, $QUIET); # begin setup of optional parameters (globals) getopts("DVQt:l:q:n:w:h:s:a:", \%opt); $DEBUG = $opt{D} || 0; $VERBOSE = $opt{V} || 1; if ($opt{Q}) { $DEBUG = 0; $VERBOSE = 0; $QUIET = 1; } my $sleepytime = $opt{n} || 5; # sleep time defaults to 5 seconds. my $quality = ( $opt{'q'} || 8 ) * 10; # quality defaults to 8 (internally 80) # Feature: -t 0.1 trims by ten percent before re-scale my $trim_fraction = $opt{'t'} || 0; # default, no trim if ($trim_fraction > 1) { warn "The -t parameter, or \"trim fraction\" must be a fraction, e.g. 0.1 or 0.2\n" unless $QUIET; } if ($trim_fraction !~ /[0-9.]/) { warn "The -t parameter, or \"trim fraction\" should be numeric, e.g. 0.1 or 0.2\n" unless $QUIET; } ($DEBUG) && print STDERR "trim_fraction: $trim_fraction\n"; # end of setup my $feh = File::ExtensionFilter->new(extensions => [ 'jpg', 'jpeg', 'png' ] ); my $image_file_rule = $feh->generate_regexp; # begin main processing my (@files, $image_file); if ($opt{l}) { my $list_file = $opt{l}; my $flh = File::FullNameLists->new(listfile=> $list_file); $flh->set_required_rule( $image_file_rule ); while( my $image_file = $flh->next() ) { rescale($image_file); sleep $sleepytime; } } else { # Look at all files in the current directory # TODO stop slurping in the entire list of files, just read them # one at a time. (memory intensive enough already). my $source = cwd(); opendir(DIR, $source) or die "can't opendir $source: $!"; chdir($source); @files = map{"$source/$_"} grep {/(?:\.jpg|\.jpeg)$/i} grep -f, readdir DIR; foreach $image_file (@files) { rescale($image_file); sleep $sleepytime; } } # end main, into the subs. # does the actual rescaling of an image sub rescale { my $image_file = shift; my $err; # my $image_mag; # my $img_height; # my $img_width; #-------- # copy original to archive location. # # process $image_file, peel off $tail my $source = $opt{s} || ''; my $archive = $opt{a} || JUNK_PRE_RESCALE; my $incoming_pat = '^ ' . JUNK_INCOMING . '(.*?) $'; my $pile_pat = '^ ' . JUNK_PILE . '(.*?) $'; ($VERBOSE) && print "processing: $image_file\n"; my $image_file_dir = dirname($image_file) or die "$image_file not valid: $!"; # TODO logic here is a little tangled. What if you had a config # file to put the defaults in... would you want this structure? my $tail; if ($image_file_dir =~ m{ $incoming_pat }x) { $tail = $1; $source ||= JUNK_INCOMING; } elsif ($image_file_dir =~ m{ $pile_pat }x) { $tail = $1; $source ||= JUNK_PILE; } elsif ( not($source) ) { # TODO Does this warning describe what actually happens? Check. print STDERR " Warning, file $image_file is in unusual place\n" . " and source root was not defined manually,\n" . " original file archived to $archive \n" . " without any path info preserved.\n" unless $QUIET; die "Actually, let's just quit!!!"; # TODO temporary $tail = ''; } elsif ( $opt{s} && not($opt{a}) ) { print STDERR " Warning, you manually defined the source root: $opt{s}\n" . " Did not manually specify the archive location. \n" . " Original is being saved to $archive. " unless $QUIET; die "Actually, let's just quit!!!"; # TODO temporary } # copy the file to the archive, creating intermediate # directories if needed (but will not overwrite an older copy) my $fph = File::Preserve->new(archive_root=>$archive, source_root=>$source); $fph->preserve($image_file); # Read in file into imagemagick my $image_mag = Image::Magick->new; $err = $image_mag->Read("$image_file"); warn "$err" if "$err" and not $QUIET; # determine the desired limits on horizontal and vertical image size my ($w_limit, $h_limit) = determine_envelope(); # Scale down $image_mag to fit within screensize (if needed) my ($img_height, $img_width) = $image_mag->Get('height', 'width'); if ( ($img_height > $h_limit) or ($img_width > $w_limit)) { my $new_height = int( $img_height * (1 - $trim_fraction) ); my $new_width = int( $img_width * (1 - $trim_fraction) ); my $shift_x = int(($trim_fraction * $img_width)/2); my $shift_y = int(($trim_fraction * $img_height)/2); my $geom = $new_width . 'x' . $new_height . '+' . $shift_x . '+' . $shift_y; $err = $image_mag->Crop( geometry=>$geom); warn "$err" if "$err" and not $QUIET; $geom = $w_limit . 'x' . $h_limit; $err = $image_mag->Scale(geometry=>$geom); warn "$err" if "$err" and not $QUIET; #-------- # Save image_file # $image_mag->Set(quality=>$quality); $err = $image_mag->Write($image_file); warn "$err" if "$err" and not $QUIET; } else { ($DEBUG) && print STDERR "Skipping rescale of $image_file\n"; } # Destroy this image object now that we're done undef $image_mag; } # determine_envelope -- # uses global options hash %opt # if both h and w have been passed in, just use them. # otherwise resort to perlTk to get screen size, but # allow override of h or w if either were specified. sub determine_envelope { my $h_limit; my $w_limit; if ( ( $opt{h} ) && ( $opt{w} ) ){ $h_limit = $opt{h}; $w_limit = $opt{w}; } else { #-------- # Get screen dimensions with perlTk (though rescale later with Image::Magick) my $mw = MainWindow->new; # Get screen dimensions my $screen_width = $mw ->screenwidth(); # 1024 my $screen_height = $mw ->screenheight(); # 768 $w_limit = $opt{w} || $screen_width; $h_limit = $opt{h} || $screen_height - 30; # less 30 to allow slack for title bars, etc. } return ($w_limit, $h_limit); } __END__ =head1 TODO o TODO the "command line" arguments are now so elaborate that they aren't really intended for human use. If this script is primarily to be used inside other scripts, then maybe it should be a library instead, eh? Think about an object, where every "cli option" will instead be object fields. system( "image_rescale -s $source -a $archive -h $height_limit -w $width_limit -l $image_list"; ); o Still use screen size for defaults, but allow passsing in a height and width from the command line. (DONE, I think, NEEDS TEST) o Switch to using my File::Preserve package to do the save of originals. (DONE, though that was awkward... NEEDS TEST) o Allow the archive location to be over-ridden also, set from the command line. Note: that also means you need to set the image stash location also, for the tree-style of "preserve" to work. (DONE) o Add a revert feature: restore original versions from the archive. o Look into working with PNG files. =head1 AUTHOR Joseph Brenner, Edoom@kzsu.stanford.eduE =head1 COPYRIGHT AND LICENSE Copyright (C) 2004 by Joseph Brenner This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.2 or, at your option, any later version of Perl 5 you may have available. =head1 BUGS Reporters are slacking. =cut