#! 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 (highest compression) ## .JPG => 0 .. 100 Worst quality (highest compression) .. Best quality (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 <] file [ ... ] where: -H gives this message and exits -VERBOSE produces some informational messages -NODUMP Inhibits the dumping of the colors (palette) if no color pairs 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 displaying it in your associate image viewer -TYPE= specifies the output type for modified image. defaults to the same as the input type, or png if the input type is unrecognised. file the path/name of the mage to be modified ... 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 avoid ## 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 to make changes or anything else to abort:" unless $NOPROMPT; if( $NOPROMPT or =~ /^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: $!"; } }