#! perl -slw ## This script will not run without the -s and -l options
+.
use strict;
use GD;
use File::Temp qw[ tempfile ];
our $H;
+ ## Usage
our $VERBOSE;
+ ## Produce informative messages
our $TYPE;
+ ## Output filetype (defaults to same as input)
our $NOPROMPT;
+ ## Prompt for confirmation unless overridden
our $NODUMP;
+ ## Dump colors if no swaps supplied
our $NOPREVIEW;
+ ## Display modifed image before commiting
our $QUALITY;
+ ## Output image quality
## .png => 0..9 Best quality (lowest compression) .. Worst quality (h
+ighest compression)
## .JPG => 0 .. 100 Worst quality (highest compression) .. Best quali
+ty (lowest compression)
## .gif => No effect.
$QUALITY = -1 unless defined $QUALITY;
+ ## Used glib compiled in defaults
our $MORE ||= $ENV{MORE} || 'more';
+ ## Program used to page dump output
our $NEAR ||= 0;
+ ## Use closestColor if exact match not found
sub rgb2n{ unpack 'N', pack 'CCCC', 0, @_ }
+ ## 3-byte RGB to 24-bit integer
sub n2rgb{ unpack 'xCCC', pack 'N', $_[0] }
+ ## 24-bit int to 3-byte rgb
my %methods = (
+ ## Could be extended to the other GD supported types
png => \&GD::Image::png,
jpg => \&GD::Image::jpeg,
jpeg => \&GD::Image::jpeg,
gif => \&GD::Image::gif,
);
print <<USAGE and exit if $H or not @ARGV;
usage: $0 [-H] [-DUMP[=0]] [-NEAR] [-PRE] [-TYPE=<jpg|png|gif>] file [
+<color pair> ... ]
where:
-H
gives this message and exits
-VERBOSE
produces some informational messages
-NODUMP
Inhibits the dumping of the colors (palette) if no color p
+airs are supplied.
-NEAR
replaces the nearest color found to the first of each pair
+ with the second (default:off)
-NOPROMPT
inhibits prompting for confirmation of modifications
-NOPREVIEW
inhibits the modified file from being previewed by display
+ing it in your associate image viewer
-TYPE=<png|jpg|gif>
specifies the output type for modified image.
defaults to the same as the input type, or png if the inpu
+t type is unrecognised.
file
the path/name of the mage to be modified
<color pair> ...
are pairs of color values. The first is looked for and if
+found, replaced by the second.
The colors can be specified in several ways:
0xhhhhhh 0xhhhhhh
xhhhhhh xhhhhhh
ddd:ddd:ddd d:d:d
The different styles can be intermixed.
USAGE
##Get filename and load image
my $file = shift @ARGV;
GD::Image->trueColor( 1 );
+ ## Start off allowing trueColor images
my $img = GD::Image->new( $file )
or die "Couldn't load image from $file: $!";
my( $typeIn ) = $file =~ m[\.(.+$)];
my( $typeOut ) = $TYPE || $typeIn;
+ ## Output same image type as input unless overridden
$VERBOSE && print "Outputting type:$typeOut";
my $outputMethod = $methods{ lc $typeOut }
+ ## Select appropriate output method
|| die "Unrecognised filetype $typeOut";
## If colorsTotal return true, it seems to indicate that the original
## file was palletised. So reload the file having turned it off to avo
+id
## conversion of the modifed output
## Is this reliable? (Seems to be!) Is there a better way?
if( $img->colorsTotal ) {
GD::Image->trueColor( 0 );
+ ## Reload without trueColor set
my $img = GD::Image->new( $file )
or die "Couldn't load image from $file: $!";
}
## Successfully opened the file so look for color swaps
my %swaps = map{
$_ = hex if m[^0?x];
+ ## Allow hex xhhhhhh or 0xhhhhhh input
$_ = rgb2n( m[^(\d+):(\d+):(\d+)$] ) if m[:];
+ ## Or rgb ddd:ddd:ddd
$_;
} @ARGV;
## Different processing required for palletised and truecolor images
unless( $img->trueColor ) {
+ ## palletised
open MORE, "| $MORE" or die $!; #*MORE = *STDOUT;
printf MORE "Image is %d x %d, and has %d colors in it's palette\n
+",
$img->getBounds, $img->colorsTotal;
if( not %swaps ) {
+ ## Dump pallete if no swaps specified
die "No swap colors specified" if $NODUMP;
+ ## and dump not overridden
print MORE "No swap colours specified; dumping palette";
printf MORE "%d: rgb(%3d:%3d:%3d) 0x%06x\n",
$_, $img->rgb( $_ ), rgb2n( $img->rgb( $_ ) )
for 0 .. $img->colorsTotal - 1;
exit;
}
close MORE;
my $transIndex = $img->transparent;
+ ## Save transparent index
$img->transparent( -1 ) if 1+$transIndex;
+ ## And remove it as it inhibits matching
for my $color ( keys %swaps ) {
my $index = $img->colorExact( n2rgb( $color ) );
+ ## Try for an exact match
if( 1+$index
+ ## If we found one
or $NEAR and 1+( $index = $img->colorClosest( n2rgb( $color )
+ ) ) ## or asked for near and we got a close match
){
$img->colorDeallocate( $index );
+ ## Do the swap
1+$img->colorAllocate( n2rgb( $swaps{ $color } ) )
or die sprintf "Failed to reallocate 0x%06x to 0x%06x\
+n",
$color, $swaps{ $color };
}
else {
warn sprintf "Couldn't match color 0x%06x\n", $color;
}
}
$img->transparent( $transIndex );
+ ## Reset transparency (if required )
}
else {
+ ## 24-bit
open MORE, "| $MORE" or die $!; #*MORE = *STDOUT;
printf MORE "Image is %d x %d, 24 bpp\n", $img->getBounds;
my $gd = $img->gd;
+ ## gd format is easiest to manipulate
my( $sig, $x, $y, $true, $transparent ) = unpack 'nnncN', $gd;
+ ## Extract some info
my %colors;
push @{ $colors{ unpack 'N', substr $gd, 11+( 4 * $_ ), 4 } }, $_
+ ## Find, count and remember the colors
for 0 .. ( $x * $y )-1;
+ ## Could blow memory for very large images!
printf MORE "Contains %d unique colors\n", scalar keys %colors;
if( not %swaps ) {
+ ## Dump the colors?
die "No swaps specified" if $NODUMP;
print MORE "No swap colours specified; dumping palette";
printf MORE "rgb(%3d:%3d:%3d) 0x%06x\n",
$img->rgb( $_ ), rgb2n( $img->rgb( $_ ) )
for sort{ $a<=>$b } keys %colors;
exit;
}
close MORE;
for my $color ( keys %swaps ) {
+ ## Do the swaps
if( exists $colors{ $color } ) {
my $replacement = pack 'N', $swaps{ $color };
substr( $gd, 11 + ( $_ * 4 ), 4 ) = $replacement
for @{ $colors{ $color } };
}
else {
warn sprintf "Couldn't match color 0x%06x\n", $color;
}
}
$img = GD::Image->newFromGdData( $gd );
+ ## Build a new image from the modified GD format data
}
my( $fh, $tempname ) = tempfile( 'TEMPXXXX', SUFFIX => ".$typeOut" );
+ ## Create a temporary Image file
binmode( $fh, ':raw' );
print $fh $img->$outputMethod( $QUALITY );
close $fh;
system $tempname unless $NOPREVIEW;
+ ## Show them the changes
printf "Enter Y<return> to make changes or anything else to abort:"
unless $NOPROMPT;
if( $NOPROMPT or <STDIN> =~ /^Y/i ) {
+ ## Backup and rename
if( $typeIn eq $typeOut ) {
if( rename $file, "$file.bak" ) {
$VERBOSE && print "$file backed up to $file.bak";
}
else {
warn "Failed to create backup file '$file.bak': $!";
}
}
$file =~s[\..*$][.$typeOut] if $TYPE;
if( rename $tempname, $file ) {
$VERBOSE && print "Modified image written to $file";
}
else {
warn "Failed to rename $tempname to $file: $!"
}
}
else {
+ ## or delete
if( unlink $tempname ) {
$VERBOSE and print "$tempname deleted; $file unchanged";
}
else {
warn "Couldn't delete tempfile $tempname: $!";
}
}
|