package Image::Pngslimmer;

use 5.008004;
use strict;
use warnings;
use Compress::Zlib;
use Compress::Raw::Zlib;
use POSIX();

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Image::Pngslimmer ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw() ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);

our $VERSION = '0.22';


sub checkcrc {
	my $chunk = shift;
	my ($chunklength, $subtocheck, $generatedcrc, $readcrc);
	#get length of data
	$chunklength = unpack("N", substr($chunk, 0, 4));
	$subtocheck = substr($chunk, 4, $chunklength + 4);
	$generatedcrc = crc32($subtocheck);
	$readcrc = unpack("N", substr($chunk, $chunklength + 8, 4));
	if ($generatedcrc eq $readcrc) {return 1;}
	#don't match
	return 0;
}
	

sub ispng {
	my $blob = shift;
	#check for signature
	my $pngsig = pack("C8", (137, 80, 78, 71, 13, 10, 26, 10));
	my $startpng = substr($blob, 0, 8);
	if ($startpng ne $pngsig) { 
		return 0;
	 }
 	#check for IHDR
	if (substr($blob, 12, 4) ne "IHDR") {
		return 0;
	}
	if (checkcrc(substr($blob, 8)) < 1) {return 0;}
	my $ihdr_len = unpack("N", substr($blob, 8, 4));	
	#check for IDAT - scanning CRCs as we go
	#scan through all the chunks looking for an IDAT header
	my $pnglength = length($blob);
	#start searching from end of IHDR chunk
	my $searchindex = 16 + $ihdr_len + 4 + 4;
	my $idatfound  = 0;
	while ($searchindex < ($pnglength - 4)) {
		if (checkcrc(substr($blob, $searchindex - 4)) < 1) {return 0;}
		if (substr($blob, $searchindex, 4) eq "IDAT") {
			$idatfound = 1;
			last;
		}
		my $nextindex = unpack("N", substr($blob, $searchindex - 4, 4));
		if ($nextindex == 0) {
			$searchindex += 5; #after a CRC if there is an empty chunk

		}
		else {
			$searchindex += ($nextindex + 4 + 4 + 4);
		}
	}
	if ($idatfound == 0) {
		return 0;
	}
	#check for IEND chunk
	#check CRC first
	if (checkcrc(substr($blob, $pnglength - 12)) < 1) {return 0;}
	if (substr($blob, $pnglength - 8, 4) ne "IEND") {
		return 0;
	}

	return 1;
}

sub shrinkchunk {
	my ($blobin, $bitblob, $blobout, $strategy, $status, $y, $level);
	$blobin = shift;
	$strategy = shift;
	$level = shift;
	unless (defined($level)){$level = Z_BEST_COMPRESSION;}
	if ($strategy eq "Z_FILTERED")	{($y, $status)=  new Compress::Raw::Zlib::Deflate(-Level => $level, -WindowBits=> -&MAX_WBITS(), -Bufsize=> 0x1000, -Strategy=>Z_FILTERED, -AppendOutput => 1);}
	else { ($y, $status) = new Compress::Raw::Zlib::Deflate(-Level => $level, -WindowBits=> -&MAX_WBITS(), -Bufsize=> 0x1000, -AppendOutput => 1);}
	unless ($status == Z_OK){ return $blobin;}
	$status = $y->deflate($blobin, $bitblob);
	unless ($status == Z_OK){ return $blobin;}
	$status = $y->flush($bitblob);
	$blobout = $blobout.$bitblob;
	unless ($status == Z_OK){ return $blobin;}
	return $blobout;
}
	
	
sub getuncompressed_data {
	my ($output, $puredata, @idats, $x, $status, $outputlump, $calc_crc, $uncompcrc);
	my $blobin = shift;
	my $pnglength = length($blobin);
	my $searchindex = 8 + 25; #start looking at the end of the IHDR
	while ($searchindex < ($pnglength - 8)) {
		my $chunklength = unpack("N", substr($blobin, $searchindex, 4));
		if (substr($blobin, $searchindex + 4, 4) eq "IDAT") {
			push (@idats, $searchindex);
		}
		$searchindex += $chunklength + 12;
	}
	my $numberofidats = @idats;
	if ($numberofidats == 0) {return undef;}
	my $chunknumber = 0;
	while($chunknumber < $numberofidats) {
		my $chunklength = unpack("N", substr($blobin, $idats[$chunknumber], 4));
		if ($chunknumber == 0) {
			if ($numberofidats == 1)
			{
				$output = substr($blobin, $idats[0] + 10, $chunklength - 2);
				last;
			}
			else
			{
				$output = substr($blobin, $idats[0] + 10, $chunklength - 2); 
			}
		}
		else {
			if (($numberofidats - 1) == $chunknumber)
			{
				$puredata = substr($blobin, $idats[$chunknumber] + 8, $chunklength); 
				$output = $output.$puredata;	
				last;
			}
			else
			{
				$puredata = substr($blobin, $idats[$chunknumber] + 8, $chunklength); 
				$output = $output.$puredata;
			}
		}
		$chunknumber++;
	}
	#have the output chunk now uncompress it
	$x = new Compress::Raw::Zlib::Inflate(-WindowBits => -&MAX_WBITS(), -ADLER32=>1, -AppendOutput=>1)
		or return undef;
	my $outlength = length($output);
	$uncompcrc = unpack("N", substr($output, $outlength - 4));
	$status = $x->inflate(substr($output, 0, $outlength - 4), $outputlump);
	unless (defined($outputlump)){ return undef;}
	$calc_crc = $x->adler32();
	if ($calc_crc != $uncompcrc) {
		return undef;}
	return $outputlump; # done
}

sub crushdatachunk {
	#look to inner stream, uncompress that, then recompress
	my ($chunkin, $datalength, $puredata, $chunkout, $crusheddata, $y, $purecrc, $blobin);
	$chunkin = shift;
	$blobin = shift;
	my $output = getuncompressed_data($blobin);
	my $lenuncomp = length($output);
	unless (defined($output)){ return $chunkin;}
	my $rawlength = length($output);
	$purecrc = adler32($output);
	# now crush it at the maximum level
	$crusheddata = shrinkchunk($output, Z_FILTERED, Z_BEST_COMPRESSION);
	my $lencompo = length($crusheddata);
	unless (length($crusheddata) < $rawlength) {$crusheddata = shrinkchunk($output, Z_DEFAULT_STRATEGY, Z_BEST_COMPRESSION);}
	my $newlength = length($crusheddata) + 6;
	#now we have compressed the data, write the chunk
	$chunkout = pack("N", $newlength);
	my $rfc1950stuff = pack("C2", (0x78,0xDA)); 
	$output = "IDAT".$rfc1950stuff.$crusheddata.pack("N", $purecrc);
	my $outCRC = crc32($output);
	$chunkout = $chunkout.$output.pack("N", $outCRC);
	return $chunkout;
}

sub zlibshrink {
	my ($blobin, $blobout, $pnglength, $ihdr_len, $searchindex, $chunktocopy, $chunklength, $processedchunk);
	$blobin = shift;
	#find the data chunks
	#decompress and then recompress
	#work out the CRC and write it out
	#but first check it is actually a PNG
	if (ispng($blobin) < 1) {
		return undef;
	}
	$pnglength = length($blobin);
	$ihdr_len = unpack("N", substr($blobin, 8, 4));
	$searchindex =  16 + $ihdr_len + 4 + 4;
	#copy the start of the incoming blob
	$blobout = substr($blobin, 0, 16 + $ihdr_len + 4);
	my $idatfound = 0;
	while ($searchindex < ($pnglength - 4)) {
		#Copy the chunk
		$chunklength = unpack("N", substr($blobin, $searchindex - 4, 4));
		$chunktocopy = substr($blobin, $searchindex - 4, $chunklength + 12);
		if (substr($blobin, $searchindex, 4) eq "IDAT") {
			if ($idatfound == 0){
				$processedchunk = crushdatachunk($chunktocopy, $blobin);
				$chunktocopy = $processedchunk;
				$idatfound = 1;
			}
			else {$chunktocopy = "";}
		}
		
		my $lenIDAT = length($chunktocopy);
		$blobout = $blobout.$chunktocopy;
		$searchindex += $chunklength + 12;
	}
	return $blobout;
}


sub linebyline {
	#analyze the data line by line
	my ($data, $ihdr)= @_;
	my %ihdr = %{$ihdr};
	my $width = $ihdr{"imagewidth"};
	my $height = $ihdr{"imageheight"};
	my $depth = $ihdr{"bitdepth"};
	my $colourtype = $ihdr{"colourtype"};
	if ($colourtype != 2) {
		return -1;
	}
	if ($depth != 8) {
		return -1;
		}
	my $count = 0;
	my $return_filtered = 1;
	while ($count < $height) {
		my $filtertype = unpack("C1", substr($data, $count * $width * 3 + $count, 1));
		if ($filtertype != 0) {$return_filtered = -1} #already filtered
		$count++;
	}
	return $return_filtered; #can be filtered?
}

sub comp_width {
	#how many bytes per pixel
	#FIX ME: only works for colour depth > 8
	my ($ihdr, %ihdr);
	$ihdr = shift;
	my $lines = $ihdr->{"imageheight"};
	my $pixels = $ihdr->{"imagewidth"};
	my $comp_width = 3;
	my $ctype = $ihdr->{"colourtype"};
	my $bdepth = $ihdr->{"bitdepth"};
	if ($ctype == 2) { #truecolour with no alpha
		if ($bdepth == 8) {$comp_width = 3;}
		else {$comp_width = 6;}
	}
	elsif (($ctype == 0)&&($bdepth == 16)) {$comp_width = 2;} #16bit grayscale
	elsif ($ctype == 4) { #grayscale with alpha
		if ($bdepth == 8) {$comp_width = 2;}
		else {$comp_width = 3;}
	}
	elsif ($ctype == 6) { #truecolour with alpha
		if ($bdepth == 8) {$comp_width = 4;}
		else {$comp_width = 7;}
	}

	return $comp_width;
}

sub filter_sub {
	#filter data schunk using Sub type
	#http://www.w3.org/TR/PNG/#9Filters
	#Filt(x) = Orig(x) - Orig(a)
	#x is byte to be filtered, a is byte to left
	my($origbyte, $leftbyte, $newbyte, $ihdr, $unfiltereddata, $filtereddata);
	$unfiltereddata = shift;
	$ihdr = shift;
	my $count = 0;
	my $count_width = 0;
	$newbyte = 0;
	my $comp_width = comp_width($ihdr);
	my $totalwidth = $ihdr->{"imagewidth"} * $comp_width;
	$filtereddata = "";
	my $lines = $ihdr->{"imageheight"};
	while ($count < $lines) {
		#start - add filtertype byte
		$filtereddata = $filtereddata."\1";
		while ($count_width < $totalwidth ) {
			$origbyte = unpack("C", substr($unfiltereddata, 1 + ($count * $totalwidth)  + $count_width + $count, 1));
			if ($count_width < $comp_width) {
				$leftbyte = 0;
			}
			else{	
				$leftbyte =  unpack("C", substr($unfiltereddata, 1 + $count + ($count * $totalwidth)  + $count_width - $comp_width, 1));
			}
			$newbyte = ($origbyte - $leftbyte)%256;
			$filtereddata = $filtereddata.pack("C", $newbyte);
			$count_width++;
		}
		$count_width = 0;
		$count++;
	}
	return $filtereddata;
}


sub filter_up {
	#filter data schunk using Up type
	my($origbyte, $upbyte, $newbyte, $ihdr, $unfiltereddata, $filtereddata);
	$unfiltereddata = shift;
	$ihdr = shift;
	my $comp_width = comp_width($ihdr);
	my $count = 0;
	my $count_width = 0;
	$newbyte = 0;
	my $totalwidth = $ihdr->{"imagewidth"} * $comp_width;
	$filtereddata = "";
	my $lines = $ihdr->{"imageheight"};
	while ($count < $lines) {
		#start - add filtertype byte
		$filtereddata = $filtereddata."\2";
		while ($count_width < $totalwidth ) {
			$origbyte = unpack("C", substr($unfiltereddata, 1 + ($count * $totalwidth)  + $count_width + $count, 1));
			if ($count == 0) {
				$upbyte = 0;
			}
			else{	
				$upbyte =  unpack("C", substr($unfiltereddata, $count + (($count - 1) * $totalwidth)  + $count_width, 1));
			}
			$newbyte = ($origbyte - $upbyte)%256;
			$filtereddata = $filtereddata.pack("C", $newbyte);
			$count_width++;
		}
		$count_width = 0;
		$count++;
	}
	return $filtereddata;
}

sub filter_ave {
	#filter data schunk using Ave type
	my($origbyte, $avebyte, $newbyte, $ihdr, $unfiltereddata, $filtereddata, $top_predictor, $left_predictor);
	$unfiltereddata = shift;
	$ihdr = shift;
	my $comp_width = comp_width($ihdr);
	my $count = 0;
	my $count_width = 0;
	$newbyte = 0;
	my $totalwidth = $ihdr->{"imagewidth"} * $comp_width;
	$filtereddata = "";
	my $lines = $ihdr->{"imageheight"};
	while ($count < $lines) {
		#start - add filtertype byte
		$filtereddata = $filtereddata."\3";
		while ($count_width < $totalwidth ) {
			$origbyte = unpack("C", substr($unfiltereddata, 1 + ($count * $totalwidth)  + $count_width + $count, 1));
			if ($count > 0) {
				$top_predictor = unpack("C", substr($unfiltereddata, $count + (($count - 1) * $totalwidth)  + $count_width, 1));
			}
			else {$top_predictor = 0;}
			if ($count_width >= $comp_width) {
				$left_predictor =  unpack("C", substr($unfiltereddata, 1 + $count + ($count * $totalwidth)  + $count_width - $comp_width, 1));
			}
			else {
				$left_predictor = 0;
			}
			$avebyte =  ($top_predictor + $left_predictor)/2;
			$avebyte = POSIX::floor($avebyte);
			$newbyte = ($origbyte - $avebyte)%256;
			$filtereddata = $filtereddata.pack("C", $newbyte);
			$count_width++;
		}
		$count_width = 0;
		$count++;
	}
	return $filtereddata;
}
			
sub filter_paeth {	#paeth predictor type filtering
	my ($origbyte, $paethbyte_a, $paethbyte_b, $paethbyte_c, $paeth_p, $paeth_pa, $paeth_pb, $paeth_pc, $paeth_predictor, $unfiltereddata, $filtereddata, $newbyte, $ihdr);
	$unfiltereddata = shift;
	$ihdr = shift;
	my $comp_width = comp_width($ihdr);
	my $count = 0;
	my $count_width = 0;
	$newbyte = 0;
	my $totalwidth = $ihdr->{"imagewidth"} * $comp_width;
	$filtereddata = "";
	my $lines = $ihdr->{"imageheight"};
	while ($count < $lines) {
		#start - add filtertype byte
		$filtereddata = $filtereddata."\4";
		while ($count_width < $totalwidth) {
			$origbyte = unpack("C", substr($unfiltereddata, 1 + ($count * $totalwidth)  + $count_width + $count, 1));
			if ($count > 0) {
				$paethbyte_b = unpack("C", substr($unfiltereddata, $count + (($count - 1) * $totalwidth)  + $count_width, 1));
			}
			else {$paethbyte_b = 0;}
			if ($count_width >= $comp_width) {
				$paethbyte_a =  unpack("C", substr($unfiltereddata, 1 + $count + ($count * $totalwidth)  + $count_width - $comp_width, 1));
			}
			else {
				$paethbyte_a = 0;
			}
			if (($count_width >= $comp_width)&&($count > 0)) {
				$paethbyte_c = unpack("C", substr($unfiltereddata, $count + (($count - 1) * $totalwidth)  + $count_width - $comp_width, 1));
			}
			else {
				$paethbyte_c = 0;
			}
			$paeth_p = $paethbyte_a + $paethbyte_b - $paethbyte_c;
			$paeth_pa = abs($paeth_p - $paethbyte_a);
			$paeth_pb = abs($paeth_p - $paethbyte_b);
			$paeth_pc = abs($paeth_p - $paethbyte_c);
			if (($paeth_pa <= $paeth_pb)&&($paeth_pa <= $paeth_pc)) { $paeth_predictor = $paethbyte_a; }
			elsif ($paeth_pb <= $paeth_pc) {$paeth_predictor = $paethbyte_b; }
			else {$paeth_predictor = $paethbyte_c;}
			$newbyte = ($origbyte - $paeth_predictor)%256;
			$filtereddata = $filtereddata.pack("C", $newbyte);
			$count_width++;
		}
		$count_width = 0;
		$count++;
	}
	return $filtereddata;
}

sub filterdata {
	my ($unfiltereddata, $ihdr, $filtereddata, $finalfiltered, $filtered_sub, $filtered_up, $filtered_ave, $filtered_paeth);
	$unfiltereddata = shift;
	$ihdr = shift;
	$filtered_sub = filter_sub($unfiltereddata, $ihdr);
	$filtered_up = filter_up($unfiltereddata, $ihdr);
	$filtered_ave = filter_ave($unfiltereddata, $ihdr);
	$filtered_paeth = filter_paeth($unfiltereddata, $ihdr);
	
	#TO DO: Try other filters and pick best one
	my $pixels = $ihdr->{"imagewidth"};
	my $rows = $ihdr->{"imageheight"};
	my $comp_width = comp_width($ihdr);
	my $bytesperline = $pixels * $comp_width;
	my $countout = 0;
	my $rows_done = 0;
	my $count_sub = 0;
	my $count_up = 0;
	my $count_ave = 0;
	my $count_zero = 0;
	my $count_paeth = 0;
	while ($rows_done < $rows)
	{
		while (($countout) < $bytesperline)
		{	
			$count_sub += unpack("c", substr($filtered_sub, 1 + ($rows_done * $bytesperline) + $countout + $rows_done, 1));
			$count_up += unpack("c", substr($filtered_up, 1 + ($rows_done * $bytesperline) + $countout + $rows_done, 1));
			$count_ave += unpack("c", substr($filtered_ave, 1 + ($rows_done * $bytesperline) + $countout + $rows_done, 1));
			$count_zero += unpack("c", substr($unfiltereddata, 1 + ($rows_done * $bytesperline) + $countout + $rows_done, 1));
			$count_paeth +=unpack("c", substr($filtered_paeth, 1 + ($rows_done * $bytesperline) + $countout + $rows_done, 1));
			$countout++;
		}
		$count_paeth = abs($count_paeth);
		$count_zero = abs($count_zero);
		$count_ave = abs($count_ave);
		$count_up = abs($count_up);
		$count_sub = abs($count_sub);
		if (($count_paeth <= $count_zero)&&($count_paeth <= $count_sub)&&($count_paeth <= $count_up)&&($count_paeth <= $count_ave))
		{
			$finalfiltered = $finalfiltered.substr($filtered_paeth, $rows_done + $rows_done * $bytesperline, $bytesperline + 1);
		}
	   	elsif (($count_ave <= $count_zero)&&($count_ave <= $count_sub)&&($count_ave <= $count_up))
		{
			$finalfiltered = $finalfiltered.substr($filtered_ave, $rows_done + $rows_done * $bytesperline, $bytesperline + 1);
		}
		elsif (($count_up <= $count_zero)&&($count_up <= $count_sub)) 
		{
			$finalfiltered = $finalfiltered.substr($filtered_up, $rows_done + $rows_done  * $bytesperline, $bytesperline + 1);
		}
		elsif ($count_sub <= $count_zero) 
		{
			$finalfiltered = $finalfiltered.substr($filtered_sub, $rows_done + $rows_done * $bytesperline, $bytesperline + 1);
		}
		else
		{
			$finalfiltered = $finalfiltered.substr($unfiltereddata, $rows_done + $rows_done * $bytesperline, $bytesperline + 1);
		}
		$countout = 0;
		$count_up = 0;
		$count_sub = 0;
		$count_zero = 0;
		$count_ave = 0;
		$count_paeth = 0;
		$rows_done++;
	}
	return $finalfiltered;
	
}

sub getihdr {
	my ($blobin, %ihdr);
	$blobin = shift;
	$ihdr{"imagewidth"} = unpack("N", substr($blobin, 16, 4));
	$ihdr{"imageheight"} = unpack("N", substr($blobin, 20, 4));
	$ihdr{"bitdepth"} = unpack("C", substr($blobin, 24, 1));
	$ihdr{"colourtype"} = unpack("C", substr($blobin, 25, 1));
        $ihdr{"compression"} = unpack("C", substr($blobin, 26, 1));
	$ihdr{"filter"} = unpack("C", substr($blobin, 27, 1));
	$ihdr{"interlace"} = unpack("C", substr($blobin, 28, 1));
	return \%ihdr;
}
	
sub filter {
 	my ($blobin, $filtereddata);
	$blobin = shift;
	#basic check so we do not waste our time
	if (ispng($blobin) < 1) {
		return undef;
	}
	#read some basic info about the PNG
	my $ihdr = getihdr($blobin);
	if ($ihdr->{"colourtype"} == 3) { return $blobin } #already palettized
	if ($ihdr->{"bitdepth"} < 8) { return $blobin; } # colour depth is so low it's not worth it
	if ($ihdr->{"compression"} != 0) {return $blobin;} # non-standard compression
	if ($ihdr->{"filter"} != 0) {return $blobin; } # non-standard filtering

	if ($ihdr->{"interlace"} != 0) {
		#FIX ME: support interlacing
		return $blobin;
	}
	my $datachunk = getuncompressed_data($blobin);
	unless (defined($datachunk)) {return $blobin;}
	my $canfilter = linebyline($datachunk, $ihdr);
	my $preproclen = length($datachunk);
	if ($canfilter > 0)
	{
		$filtereddata = filterdata($datachunk, $ihdr);
	}
	else {return $blobin;}
	my $postproclen = length($filtereddata);
        #Now stick the uncompressed data into a chunk
	#and return - leaving the compression to a different process
        my $filteredcrc = adler32($filtereddata);
	$filtereddata = shrinkchunk($filtereddata, Z_FILTERED, Z_BEST_SPEED);
	my $filterlen = length($filtereddata);
	#now push the data into the PNG
        my $pnglength = length($blobin);
        my $ihdr_len = unpack("N", substr($blobin, 8, 4));
        my $searchindex =  16 + $ihdr_len + 4 + 4;
        #copy the start of the incoming blob
        my $blobout = substr($blobin, 0, 16 + $ihdr_len + 4);
	my $foundidat = 0;
        while ($searchindex < ($pnglength - 4)) {
	        #Copy the chunk
                my $chunklength = unpack("N", substr($blobin, $searchindex - 4, 4));
                my $chunktocopy = substr($blobin, $searchindex - 4, $chunklength + 12);
                if (substr($blobin, $searchindex, 4) eq "IDAT") {
			if ($foundidat == 0) { #ignore any additional IDAT chunks
				my $rfc1950stuff = pack("C2", (0x78, 0x5E));
				my $output = "IDAT".$rfc1950stuff.$filtereddata.pack("N", $filteredcrc);
				my $newlength = $filterlen + 6;
				my $outCRC = crc32($output);
				my $processedchunk = pack("N", $newlength).$output.pack("N", $outCRC);
				$chunktocopy = $processedchunk;
				$foundidat = 1;
			}
			else {$chunktocopy = "";}
                }
                $blobout = $blobout.$chunktocopy;
                $searchindex += $chunklength + 12;
	}
        return $blobout;
}

sub discard_noncritical {
	my ($blob, $cleanblob, $searchindex, $pnglength, $chunktext, $nextindex);
	$blob = shift;
	if (ispng($blob) < 1) { return $blob; } #not a PNG so just return the blob unaltered
	#we know we have a png = so go straight to the IHDR chunk
	#copy signature and text + length from IHDR
	$cleanblob = substr($blob, 0, 16);
	#get length of IHDR
	my $ihdr_len = unpack("N", substr($blob, 8, 4));
	#copy IHDR data + CRC
	$cleanblob = $cleanblob.substr($blob, 16, $ihdr_len + 4);
	#move on to next text field
	$searchindex = 16 + $ihdr_len + 8;
	$pnglength = length($blob);
	while ($searchindex < ($pnglength - 4)) {
		#how big is chunk?
		$nextindex = unpack("N", substr($blob, $searchindex - 4, 4));
		#is chunk critcial?
		$chunktext = substr($blob, $searchindex, 1);
		if ((ord($chunktext) & 0x20) == 0 ) {
			#critcial chunk so copy
			#copy length (4), text (4), data, CRC (4)
			$cleanblob = $cleanblob.substr($blob, $searchindex - 4, 4 + 4 + $nextindex + 4);
		}
		#update the searchpoint - 4 + data length + CRC (4) + 4 to get to the text
		$searchindex += $nextindex + 12;
	}
	return $cleanblob;
}

sub ispalettized {
	my ($blobin, $ihdr, %ihdr);
	$blobin = shift;
	$ihdr = getihdr($blobin);
	%ihdr = %{$ihdr};
	return 0 unless $ihdr{"colourtype"} == 3;
	return 1;
}

sub unfiltersub {
	my ($chunkin, $lines_done, $linelength, $lineout, $comp_width, $addition);
	($chunkin, $lines_done, $linelength, $comp_width) = @_;
	my $pointis = 1;
	while ($pointis < $linelength)
	{
		my $reconbyte = unpack("C", substr($chunkin, $lines_done * $linelength + $pointis, 1));
		if ($pointis > $comp_width) {
			$addition = unpack("C", substr($lineout, $pointis - $comp_width - 1, 1));
		}
		else {$addition = 0;}
		$reconbyte = ($reconbyte + $addition)%256;
		$lineout = $lineout.pack("C", $reconbyte);
		$pointis++;
	}
	$lineout = "\0".$lineout;
	return $lineout;
}

sub unfilterup {
	my ($chunkin, $chunkout, $lines_done, $linelength, $lineout,  $addition);
	($chunkin, $chunkout, $lines_done, $linelength) = @_;
	my $pointis = 1;
	while ($pointis < $linelength)
	{
		my $reconbyte = unpack("C", substr($chunkin, $lines_done * $linelength + $pointis, 1));
		if ($lines_done > 0) {
			$addition = unpack("C", substr($chunkout, ($lines_done - 1) * $linelength + $pointis, 1));
		}
		else {$addition = 0;}
		$reconbyte = ($reconbyte + $addition)%256;
		$lineout = $lineout.pack("C", $reconbyte);
		$pointis++;
	}
	$lineout = "\0".$lineout;
	return $lineout;
}
	
sub unfilterave {
	my ($chunkin, $chunkout, $lines_done, $linelength, $lineout, $compwidth, $addition, $addition_up, $addition_left);
	($chunkin, $chunkout, $lines_done, $linelength, $compwidth) = @_;
	my $pointis = 1;
	while ($pointis < $linelength)
	{
		my $reconbyte = unpack("C", substr($chunkin, $lines_done * $linelength + $pointis, 1));
		if ($lines_done > 0) {
			$addition_up = unpack("C", substr($chunkout, ($lines_done - 1) * $linelength + $pointis, 1));
		}
		else {$addition_up = 0;}
		if ($pointis > $compwidth) {
			$addition_left = unpack("C", substr($lineout, $pointis - $compwidth - 1, 1));
		}
		else {$addition_left = 0;}
		$addition = POSIX::floor(($addition_up + $addition_left)/2);
		$reconbyte = ($reconbyte + $addition)%256;
		$lineout = $lineout.pack("C", $reconbyte);
		$pointis++;
	}
	$lineout = "\0".$lineout;
	return $lineout;
}

sub unfilterpaeth {
	my ($chunkin, $chunkout, $lines_done, $linelength, $lineout, $compwidth, $addition, $addition_up, $addition_left, $addition_uleft);
	($chunkin, $chunkout, $lines_done, $linelength, $compwidth) = @_;
	my $pointis = 1;
	while ($pointis < $linelength)
	{
		my $reconbyte = unpack("C", substr($chunkin, $lines_done * $linelength + $pointis, 1));
		if ($lines_done > 0) {
			$addition_up = unpack("C", substr($chunkout, ($lines_done - 1) * $linelength + $pointis, 1));
			if ($pointis > $compwidth) {
				$addition_uleft = unpack("C", substr($chunkout, ($lines_done - 1) * $linelength + $pointis - $compwidth, 1));
			}
			else {
				$addition_uleft = 0;
			}
		}
		else {
			$addition_up = 0;
			$addition_uleft = 0;
		}
		if ($pointis > $compwidth) {
			$addition_left = unpack("C", substr($lineout, $pointis - $compwidth - 1, 1));
		}
		else {$addition_left = 0;}
		my $paeth_p = $addition_up + $addition_left - $addition_uleft;
		my $paeth_a = abs($paeth_p - $addition_left);
		my $paeth_b = abs($paeth_p - $addition_up);
		my $paeth_c = abs($paeth_p - $addition_uleft);
		if (($paeth_a <= $paeth_b) && ($paeth_a <= $paeth_c)) { $addition = $addition_left;}
		elsif ($paeth_b <= $paeth_c) {$addition = $addition_up;}
		else {$addition = $addition_uleft;}
		my $recbyte = ($reconbyte + $addition)%256;
		$lineout = $lineout.pack("C", $recbyte);
		$pointis++;
	}
	$lineout = "\0".$lineout;
	return $lineout;
}


sub unfilter {
	my  ($blobin, $chunkin, $chunkout, $ihdr, %ihdr, $imageheight, $imagewidth);
	$chunkin = shift;
	$ihdr = shift;
	$imageheight = $ihdr->{"imageheight"};
	$imagewidth = $ihdr->{"imagewidth"};
	#get each line
	my $lines_done = 0;
	my $pixels_done = 0;
	my $comp_width = comp_width($ihdr);
	my $linelength = $comp_width * $imagewidth + 1;
	while ($lines_done < $imageheight)
	{
		my $filtertype = unpack("C", substr($chunkin, $lines_done * $linelength, 1));
		if ($filtertype == 0) {
			#line not filtered at all
			$chunkout = $chunkout.substr($chunkin,  $lines_done * $linelength, $linelength);
		}
		elsif ($filtertype == 4) {
			$chunkout = $chunkout.unfilterpaeth($chunkin, $chunkout, $lines_done, $linelength, $comp_width);
		}
		elsif ($filtertype == 1) {
			$chunkout = $chunkout.unfiltersub($chunkin, $lines_done, $linelength, $comp_width);
		}
		elsif ($filtertype == 2) {
			$chunkout = $chunkout.unfilterup($chunkin, $chunkout, $lines_done, $linelength);
		}
		else {
			$chunkout = $chunkout.unfilterave($chunkin, $chunkout, $lines_done, $linelength, $comp_width);
		}
		$lines_done++;
	}
	return $chunkout;
}

sub countcolours {
	my ($chunk, $limit, %colourlist, %ihdr, $ihdr, $totallines, $width, $cdepth, $x, $colourfound);
	($chunk, $ihdr) = @_;
	$totallines = $ihdr->{"imageheight"};
	$width = $ihdr->{"imagewidth"};
	$cdepth = comp_width($ihdr);
	my $linesdone = 0;
	my $linelength = $width * $cdepth + 1;
	my $coloursfound = 0;
	while ($linesdone < $totallines)
	{
		my $pixelpoint = 0;
		while ($pixelpoint < $width)
		{
			#FIX ME - needs to work with alpha too
			$colourfound = substr($chunk, ($pixelpoint * $cdepth) + ($linesdone * $linelength) + 1, $cdepth);
			my $colour = 0;
			for ($x = 0; $x < $cdepth; $x++)
			{
				$colour = $colour<<8|ord(substr($colourfound, $x, 1));
			}
			if (defined($colourlist{$colour})) { $colourlist{$colour}++;}
			else {
				$colourlist{$colour} = 1;
				$coloursfound++;
			}
			$pixelpoint++;
		}
		$linesdone++;
	}
	
	return ($coloursfound, \%colourlist);
}
		
sub reportcolours {
	my ($colour_limit, $blobin, $filtereddata, %ihdr, $ihdr, $blobout, $ihdr_chunk, $pal_chunk, $x, %palindex, $palindex, $colourfound);
	my ($colourlist, %colourlist, $colours);
	$blobin = shift;
	#is it a PNG
	unless( ispng($blobin) > 0)
	{
		print "Supplied image is not a PNG\n";
		return -1;
	}
	#is it already palettized?
	unless (ispalettized($blobin) < 1)
	{
		print "Supplied image is indexed.\n";
		return -1;
	}
	$filtereddata = getuncompressed_data($blobin);
	%ihdr = %{getihdr($blobin)};
	my $unfiltereddata = unfilter($filtereddata, \%ihdr);
	($colours, $colourlist) = countcolours($unfiltereddata, \%ihdr);
	%colourlist = %{$colourlist};
	my @inputlist = keys(%colourlist);
	return \%colourlist;
}
		
sub indexcolours {
	# take PNG and count colours
	my ($colour_limit, $blobin, $filtereddata, %ihdr, $ihdr, $blobout, $ihdr_chunk, $pal_chunk, $x, %palindex, $palindex, $colourfound);
	my ($colourlist, %colourlist, $colours);
	$blobin = shift;
	#is it a PNG
	return $blobin unless ispng($blobin) > 0;
	#is it already palettized?
	return $blobin unless ispalettized($blobin) < 1;
	$colour_limit = shift; 
	#0 means no limit
	$colour_limit = 0 unless $colour_limit;
	$filtereddata = getuncompressed_data($blobin);
	$ihdr = getihdr($blobin);
	my $unfiltereddata = unfilter($filtereddata, $ihdr);
	($colours, $colourlist) = countcolours($unfiltereddata, $ihdr);
	if ($colours < 1) {return $blobin;}
	#to write out an indexed version $colours has to be less than 256
	if ($colours < 256) {
		#have to rewrite the whole thing now
		#start with the PNG header
		$blobout = pack("C8", (137, 80, 78, 71, 13, 10, 26, 10));
		#now the IHDR
		$blobout = $blobout.pack("N", 0x0D);
		$ihdr_chunk = "IHDR";
		$ihdr_chunk = $ihdr_chunk.pack("N2", ($ihdr->{"imagewidth"}, $ihdr->{"imageheight"}));
		#FIX ME: Support index of less than 8 bits
		$ihdr_chunk = $ihdr_chunk.pack("C2", (8, 3)); #8 bit indexed colour
		$ihdr_chunk = $ihdr_chunk.pack("C3", ($ihdr->{"compression"}, $ihdr->{"filter"}, $ihdr->{"interlace"}));
		my $ihdrcrc = crc32($ihdr_chunk);
		$blobout = $blobout.$ihdr_chunk.pack("N", $ihdrcrc);
		#now any chunk before the IDAT
        	my $searchindex =  16 + 13 + 4 + 4;
		my $pnglength = length($blobin);
		my $foundidat = 0;
        	while ($searchindex < ($pnglength - 4)) {
	        #Copy the chunk
	                my $chunklength = unpack("N", substr($blobin, $searchindex - 4, 4));
        	        my $chunktocopy = substr($blobin, $searchindex - 4, $chunklength + 12);
                	if (substr($blobin, $searchindex, 4) eq "IDAT") {
				if ($foundidat == 0) { #ignore any additional IDAT chunks
					#now the palette chunk
					$pal_chunk = "";
					my %colourlist = %{$colourlist};
					my $palcount = 0;
					foreach $x (keys %colourlist)
					{	
						$pal_chunk = $pal_chunk.pack("C3", ($x>>16, ($x & 0xFF00)>>8, $x & 0xFF));
						#use a second hash to record where the colour is in the palette
						$palindex{$x} = $palcount;
						$palcount++;
					}
					my $pal_crc = crc32("PLTE".$pal_chunk);
					my $len_pal = length($pal_chunk);
					$blobout = $blobout.pack("N", $len_pal)."PLTE".$pal_chunk.pack("N", $pal_crc);
					#now process the IDAT
					my $dataout;
					my $linesdone = 0;
					my $totallines = $ihdr->{"imageheight"};
					my $width = $ihdr->{"imagewidth"};
					my $cdepth = comp_width($ihdr);
					my $linelength = $width * $cdepth + 1;
					while ($linesdone < $totallines)
					{
						$dataout = $dataout."\0";
						my $pixelpoint = 0;
						while ($pixelpoint < $width)
						{
							#FIX ME - needs to work with alpha too
							$colourfound = substr($unfiltereddata, ($pixelpoint * $cdepth) + ($linesdone * $linelength) + 1, $cdepth);
							my $colour = 0;
							for ($x = 0; $x < $cdepth; $x++)
							{
								$colour = $colour<<8|ord(substr($colourfound, $x, 1));
							}
							$dataout = $dataout.pack("C", $palindex{$colour});
							$pixelpoint++;
						}
						$linesdone++;
					}
					#now to deflate $dataout to get proper stream
					
					my $rfc1950stuff = pack("C2", (0x78, 0x5E));
					my $rfc1951stuff = shrinkchunk($dataout, Z_DEFAULT_STRATEGY, Z_BEST_SPEED);
					my $output = "IDAT".$rfc1950stuff.$rfc1951stuff.pack("N", adler32($dataout));
					my $newlength = length($output) - 4;
					my $outCRC = crc32($output);
					my $processedchunk = pack("N", $newlength).$output.pack("N", $outCRC);
					$chunktocopy = $processedchunk;
					$foundidat = 1;
				}
				else {$chunktocopy = "";}
	                }
        	        $blobout = $blobout.$chunktocopy;
                	$searchindex += $chunklength + 12;
		}
	}
	else {return $blobin;}
	return $blobout;
	
}

	
sub convert_toxyz {
	#convert 24 bit number to cartesian point
	my $inpoint = shift;
	return ($inpoint>>16, ($inpoint & 0xFF00)>>8, $inpoint & 0xFF);
}

sub convert_tocolour {
	#convert cartesian to RGB colour
	my ($x, $y, $z) = @_;
	return (($x << 16)|($y << 8)|($z));
}

sub getcolour_ave {
	my ($red, $green, $blue, @coloursin, $numb, $x, @cartesians);
	#@coloursin = @_;
	my $coloursin = shift;
	$numb = scalar(@$coloursin);
	if ($numb == 0) { return (0,0,0); };
	for ($x = 0; $x < $numb; $x++)
	{
		my @cartesians = convert_toxyz($coloursin->[$x]);
		$red += $cartesians[0];
		$green += $cartesians[1];
		$blue += $cartesians[2];
	}
	$red = ($red/$numb);
	$green = ($green/$numb);
	$blue = ($blue/$numb);
	return ($red, $green, $blue);
}


sub getaxis_details {
	#return a reference to the longestaxis and its length
	my ($boundingbox, @boundingbox, $longestaxis, $length, $i, @details);
	$boundingbox = shift;
	return (0,0) unless defined ($boundingbox->[5]);
	$longestaxis = 0;
	my @lengths;
	$lengths[0] = $boundingbox->[3] - $boundingbox->[0];
	$lengths[1] = $boundingbox->[4] - $boundingbox->[1];
	$lengths[2] = $boundingbox->[5] - $boundingbox->[2];
	for ($i = 1; $i < 3; $i++)
	{
		if ($lengths[$i] > $lengths[$longestaxis]) { $longestaxis = $i;}
	}
	my $longestaxis_cor = 2 - $longestaxis;
	return ($longestaxis_cor, $lengths[$longestaxis]);
}

sub getbiggestbox {
	#return the index to the biggest box
	my ($boxesin, $i, $n);
	$boxesin = shift;
	$n = shift; 
	my $z = 0;
	my $counter = 0;
	my $biggest = 0;
	for ($i = 0; $i < $n; $i++)
	{
		#length is 4th item per box
		$counter = $i * 4 + 3;
		if ($boxesin->[$counter] > $z)
		{
			$z = $boxesin->[$counter];
			$biggest = $i;
		}
	}
	return $biggest;
}

sub sortonaxes {
	my ($boundingref, $coloursref, $longestaxis, $lengthofaxis) = @_;
	my (@colours, $x, %distances, $distance, @outputlist, @newcolours);
	@newcolours = @$coloursref;
	if ($longestaxis == 2)
	{
		#can just sort on the whole number if red
		@newcolours = sort {$a <=> $b} @newcolours;
		return \@newcolours;
	}
	my $axisfactor = 8 * $longestaxis;
	foreach $x (@newcolours)
	{
		#FIX ME: Only works for 24 bit images
		$distance = ($x>>$axisfactor)&0xFF;
		$distances{$x} = $distance;
	}
	foreach $x (sort {$distances{$a} <=> $distances{$b}} keys %distances)
	{
		push @outputlist, $x;
	}
	return \@outputlist;
}


sub getRGBbox {
	my $points = shift;
	my ( @reds, @greens, @blues, $numb, $x);
	$numb = @$points;
	for ($x = 0; $x < $numb; $x += 3)
	{
		push @reds, $points->[$x];
		push @greens, $points->[$x + 1];
		push @blues, $points->[$x + 2];
	}
	@reds = sort {$a <=> $b} @reds;
	@greens = sort {$a <=> $b} @greens;
	@blues = sort {$a <=> $b} @blues;
	my $boundref = [shift @reds, shift @greens, shift @blues, pop @reds, pop @greens, pop @blues];
	return $boundref;
	
}

sub generate_box {
	#convert colours to cartesian points
	#and then return the bounding box
	my (@colourpoints, $x);
	foreach $x (@_)
	{
		push @colourpoints, convert_toxyz($x);
	}
	if (scalar(@colourpoints) == 3) { return \@colourpoints;}
	my $boundref = getRGBbox(\@colourpoints);
	return $boundref;
}	


sub getpalette {
	my ($x, @onebox,  @colours, @palette, %lookup, $lookup, $boxes, $z, $colours);
	my @boxes = @_;
	#eachbox has four references
	my $colnumbers = scalar(@boxes)/4;
	for ($x = 0; $x < $colnumbers; $x++)
	{
		$colours = $boxes[$x * 4 + 1];
		@colours = @$colours;
		push @palette, getcolour_ave(\@colours);
		foreach $z (@colours)
		{
			$lookup{$z} = $x;
		}
	}
	return (\@palette, \%lookup);
}

sub closestmatch_inRGB {
	my ($distance, $index, $colourin, $ciR, $ciG, $ciB, $pR, $pG, $pB, $palref, $maxindex, $cdepth, $x, $q);
	($palref, $colourin, $cdepth) = @_;
	my @pallist = @$palref;
	$index = 0;
	$distance = 0xFFFFFFFF; #big distance to start
	$maxindex = scalar(@pallist)/3; # assuming three colours
	($ciR, $ciG, $ciB) = convert_toxyz($colourin);
	for ($x = 0; $x < $maxindex; $x++)
	{
		$q = $x * 3;
		$pR = $pallist[$q] - $ciR;
		$pG = $pallist[$q + 1] - $ciG;
		$pB = $pallist[$q + 2] - $ciB;
		my $newdistance =  $pR * $pR + $pG * $pG + $pB * $pB;
		if ($newdistance < $distance) {
			$distance = $newdistance;
			$index = $x;
			if ($distance <=9) {return $index;} #probably a good enough match!
		}
	}
	return $index; #should be the closest palette entry
}
		
sub index_mediancut {
	my ($colour_numbers, $colourlist, %colourlist, @colourkeys, @boundingbox, @colourpoints, $colourspaces, $colcount, @boxes);
	my ($boxtocut, @biggestbox, $median, @newbox, $biggestbox);
	my (@palette, %lookup, $lookup, $palref, $lookupref, @axisstuff, $sortedcolours, $boxout);
	($colourlist, $colourspaces) = @_;
	if (!defined($colourspaces)||($colourspaces == 0)) {$colourspaces = 256;}
	$colcount = 0;
	%colourlist = %{$colourlist};
	@colourkeys = keys(%colourlist);
	#can now define the colour space
	# boxes data is 
	# reftoboundingboxarray, reftocoloursarray, longest_axis, length_of_longest_axis
	my $refbigbox = generate_box(@colourkeys);
	push @boxes, $refbigbox;
	push @boxes, \@colourkeys;
	push @boxes, getaxis_details($refbigbox);
	$boxtocut = 0;
	do {
		#find the biggest box
		$boxtocut = getbiggestbox(\@boxes, $colcount) unless $colcount == 0;
		@biggestbox = splice(@boxes, $boxtocut * 4, 4);
		#now sort on the axis
		$sortedcolours = sortonaxes(@biggestbox);
		my @sortedcolours = @$sortedcolours;
		$median = POSIX::floor(scalar(@sortedcolours)/2);
		#cut the colours in half
		my @lowercolours = splice(@sortedcolours, 0, $median);
		#generate two boxes
		my $refboxa = generate_box(@lowercolours);
		push @boxes, $refboxa;
		push @boxes, \@lowercolours;
		push @boxes, getaxis_details($refboxa);
		my $refboxb = generate_box(@sortedcolours);
		push @boxes, $refboxb;
		push @boxes, \@sortedcolours;
		push @boxes, getaxis_details($refboxb);
		$colcount = scalar(@boxes) /4;
	} until ($colourspaces == $colcount);
	return getpalette(@boxes);
}
		

sub dither {
	#implement Floyd - Steinberg error diffusion dither
	my ($colour, $unfiltereddata, $cdepth, $linesdone, $pixelpoint, $totallines, $pallookref, $paloutref, $pal_chunk, $width) = @_;
	my $linelength = $width * $cdepth + 1;
	#FIX ME not just 24 bit depth
	my %colourlookup = %$pallookref;
	my ($rcomp, $gcomp, $bcomp) = convert_toxyz($colour);
 	my $palnumber = $colourlookup{$colour};
	if (!$palnumber) {
		$palnumber = closestmatch_inRGB($paloutref, $colour, $cdepth);
	}
	my ($rp, $rg, $rb) = unpack("C3", substr($pal_chunk, $palnumber * 3, 3));
	#calculate the errors
	my @colerror = ();
	$colerror[0] = $rcomp - $rp;
	$colerror[1] = $gcomp - $rg;
	$colerror[2] = $bcomp - $rb;
	#now diffuse the errors
	my ($unpacked, $max_value);
	if ($cdepth == 6) {$max_value = 0xFFFF;}
	else {$max_value = 0xFF;}
	my $currentoffset_w = $pixelpoint * $cdepth;
	my $currentoffset_h = $linesdone * $linelength;
	my $nextoffset_h = ($linesdone + 1) * $linelength;
	for (my $ll = 0; $ll < $cdepth; $ll++)
	{
		if (($pixelpoint + 1) < $width) { 
			$unpacked = unpack("C", substr($unfiltereddata, $currentoffset_w + $currentoffset_h + 1 + $cdepth + $ll, 1));
			$unpacked += ($colerror[$ll] * 7)/16;
			if ($unpacked > $max_value) { $unpacked = $max_value; }
			elsif ($unpacked < 0) { $unpacked = 0; }
			substr($unfiltereddata, $currentoffset_w + $currentoffset_h + 1 + $cdepth + $ll, 1) = pack("C", $unpacked);
			if (($linesdone + 1) < $totallines)
			{
				$unpacked = unpack("C", substr($unfiltereddata, $currentoffset_w + (($linesdone + 1) * $linelength) + 1 + $cdepth + $ll, 1));
				$unpacked += $colerror[$ll]/16;
				if ($unpacked > $max_value) { $unpacked = $max_value; }
				elsif ($unpacked < 0) { $unpacked = 0; }
				substr($unfiltereddata, $currentoffset_w + $nextoffset_h + 1 + $cdepth + $ll, 1) = pack("C", $unpacked);
			}
		}
		if (($linesdone + 1) < $totallines)
		{
			$unpacked = unpack("C", substr($unfiltereddata, $currentoffset_w + $nextoffset_h + 1 + $ll, 1));
			$unpacked += ($colerror[$ll] * 5)/16;
			if ($unpacked > $max_value) { $unpacked = $max_value; }
			elsif ($unpacked < 0) { $unpacked = 0; }
			substr($unfiltereddata, $currentoffset_w + $nextoffset_h + 1 + $ll, 1) = pack("C", $unpacked);
			if ($pixelpoint > 0) { 
				$unpacked = unpack("C", substr($unfiltereddata, $currentoffset_w + $nextoffset_h + 1 - $cdepth + $ll, 1));
				$unpacked += ($colerror[$ll] * 3)/16;
				if ($unpacked > $max_value) { $unpacked = $max_value; }
				elsif ($unpacked < 0) { $unpacked = 0; }
				substr($unfiltereddata, $currentoffset_w + $nextoffset_h + 1 - $cdepth + $ll, 1) = pack("C", $unpacked);
			}
		}
	}

	return ($palnumber, $unfiltereddata);
}

	

sub palettize {
	# take PNG and count colours
	my ($colour_limit, $blobin, $filtereddata, %ihdr, $ihdr, $blobout, $ihdr_chunk, $pal_chunk, $x, %palindex, $palindex, $colourfound);
	my ($colourlist, %colourlist, $colours, $paloutref, $pallookref, $palnumb);
	$blobin = shift;
	#is it a PNG
	return $blobin unless ispng($blobin) > 0;
	#is it already palettized?
	return $blobin unless ispalettized($blobin) < 1;
	$colour_limit = shift; 
	#0 means no limit
	$colour_limit = 0 unless $colour_limit;
	my $dither = shift;
	$dither = 0 unless $dither;
	$filtereddata = getuncompressed_data($blobin);
	$ihdr = getihdr($blobin);
	my $unfiltereddata = unfilter($filtereddata, $ihdr);
	($colours, $colourlist) = countcolours($unfiltereddata, $ihdr);
	if ($colours < 1) {return $blobin;}
	if (($colours < 256)&&(($colours < $colour_limit)||($colour_limit == 0))) {return indexcolours($blobin);}
	if ($colour_limit > 256) {return undef;}
	($paloutref, $pallookref) =  index_mediancut($colourlist, $colour_limit);
	#have to rewrite the whole thing now
	#start with the PNG header
	$blobout = pack("C8", (137, 80, 78, 71, 13, 10, 26, 10));
	#now the IHDR
	$blobout = $blobout.pack("N", 0x0D);
	$ihdr_chunk = "IHDR";
	$ihdr_chunk = $ihdr_chunk.pack("N2", ($ihdr->{"imagewidth"}, $ihdr->{"imageheight"}));
	#FIX ME: Support index of less than 8 bits
	$ihdr_chunk = $ihdr_chunk.pack("C2", (8, 3)); #8 bit indexed colour
	$ihdr_chunk = $ihdr_chunk.pack("C3", ($ihdr->{"compression"}, $ihdr->{"filter"}, $ihdr->{"interlace"}));
	my $ihdrcrc = crc32($ihdr_chunk);
	$blobout = $blobout.$ihdr_chunk.pack("N", $ihdrcrc);
	#now any chunk before the IDAT
       	my $searchindex =  16 + 13 + 4 + 4;
	my $pnglength = length($blobin);
	my $foundidat = 0;
       	while ($searchindex < ($pnglength - 4)) {
       		#Copy the chunk
	        my $chunklength = unpack("N", substr($blobin, $searchindex - 4, 4));
                my $chunktocopy = substr($blobin, $searchindex - 4, $chunklength + 12);
               	if (substr($blobin, $searchindex, 4) eq "IDAT") {
			if ($foundidat == 0) { #ignore any additional IDAT chunks
				#now the palette chunk
				$pal_chunk = "";
				my @colourlist = @$paloutref;
				my $palcount = 0;
				foreach $x (@colourlist)
				{
					$pal_chunk = $pal_chunk.pack("C", $x);					
				}
				my $pal_crc = crc32("PLTE".$pal_chunk);
				my $len_pal = length($pal_chunk);
				$blobout = $blobout.pack("N", $len_pal)."PLTE".$pal_chunk.pack("N", $pal_crc);
				#now process the IDAT
				my $dataout;
				my $linesdone = 0;
				my $totallines = $ihdr->{"imageheight"};
				my $width = $ihdr->{"imagewidth"};
				my $cdepth = comp_width($ihdr);
				my $linelength = $width * $cdepth + 1;
				my %colourlookup = %{$pallookref};
				my ($colour, $palnumber);
				while ($linesdone < $totallines)
				{
					$dataout = $dataout."\0";
					my $pixelpoint = 0;
					my $linemarker = $linesdone * $linelength + 1;
					while ($pixelpoint < $width)
					{
						#FIX ME - needs to work with alpha too
						$colourfound = substr($unfiltereddata, ($pixelpoint * $cdepth) + $linemarker, $cdepth);
						$colour = 0;
						for ($x = 0; $x < $cdepth; $x++)
						{
							$colour = ($colour<<8|ord(substr($colourfound, $x, 1)));		
						}
						if ($dither == 1)
						{
							#add the new match to the palette if required
							if (!$colourlookup{$colour}) {
								($palnumb, $unfiltereddata) = dither($colour, $unfiltereddata, $cdepth, $linesdone, $pixelpoint, $totallines, \%colourlookup, $paloutref, $pal_chunk, $width);
								$colourlookup{$colour} = $palnumb;
							}
							else {
								#process the error but leave the palette alone
								($palnumb, $unfiltereddata) = dither($colour, $unfiltereddata, $cdepth, $linesdone, $pixelpoint, $totallines, \%colourlookup, $paloutref, $pal_chunk, $width);
							}
						}
						$dataout = $dataout.pack("C", $colourlookup{$colour});
						$pixelpoint++;
					}	
					$linesdone++;
				}
				#now to deflate $dataout to get proper stream
				my $rfc1950stuff = pack("C2", (0x78, 0x5E));
				my $rfc1951stuff = shrinkchunk($dataout, Z_DEFAULT_STRATEGY, Z_BEST_SPEED);
				my $output = "IDAT".$rfc1950stuff.$rfc1951stuff.pack("N", adler32($dataout));
				my $newlength = length($output) - 4;
				my $outCRC = crc32($output);
				my $processedchunk = pack("N", $newlength).$output.pack("N", $outCRC);
				$chunktocopy = $processedchunk;
				$foundidat = 1;
			}
			else {$chunktocopy = "";}
		}
        	$blobout = $blobout.$chunktocopy;
               	$searchindex += $chunklength + 12;
	}
	return $blobout;
}
	
	
sub analyze {
	my ($blob, $chunk_desc, $chunk_text, $chunk_length, $chunk_CRC, $crit_status, $pub_status, @chunk_array, $searchindex, $pnglength, $nextindex);
	my ($chunk_CRC_checked);
	$blob = shift;
	#is it a PNG?
	if (Image::Pngslimmer::ispng($blob) < 1){
		#no it's not, so return a simple array stating so
		push (@chunk_array, "Not a PNG file");
		return @chunk_array;
	}
	#ignore signature - it's not a chunk
	#so straight to IHDR
	$searchindex = 12;
	$pnglength = length($blob);
	while ($searchindex < ($pnglength - 4)) {
		#get datalength
		$chunk_length = unpack("N", substr($blob,  $searchindex - 4, 4));
		#name of chunk
		$chunk_text = substr($blob, $searchindex, 4);
		#chunk CRC
		$chunk_CRC = unpack("N", substr($blob, $searchindex + $chunk_length, 4));
		#is CRC correct?
		$chunk_CRC_checked = checkcrc(substr($blob, $searchindex - 4));
		#critcal chunk?
		$crit_status = 0;
		if ((ord($chunk_text) & 0x20) == 0) {$crit_status = 1;}
		#public or private chunk?
		$pub_status = 0;
		if ((ord(substr($blob, $searchindex + 1, 1)) & 0x20) == 0) {$pub_status = 1;}
		$nextindex = $searchindex - 4;
		$chunk_desc = $chunk_text." begins at offset $nextindex has data length $chunk_length with CRC $chunk_CRC";
		if ($chunk_CRC_checked == 1) {
			$chunk_desc = $chunk_desc." and the CRC is good -";
		}
		else {$chunk_desc = $chunk_desc." and there is an ERROR in the CRC -";}
		if ($crit_status > 0) { $chunk_desc = $chunk_desc." the chunk is critical to the display of the PNG"; }
		else { $chunk_desc = $chunk_desc." the chunk is not critical to the display of the PNG"; }
		if ($pub_status > 0) { $chunk_desc = $chunk_desc." and is public\n"; }
		else { $chunk_desc = $chunk_desc." and is private\n"; }
		push (@chunk_array, $chunk_desc);
		$searchindex += $chunk_length + 12;
	}
	return @chunk_array;
}


1;
__END__


=pod

=head1 NAME

Image::Pngslimmer - slims (dynamically created) PNGs

=head1 SYNOPSIS

	$ping = ispng($blob)				#is this a PNG? $ping == 1 if it is
	$newblob = discard_noncritical($blob)  		#discard non critcal chunks and return a new PNG
	my @chunklist = analyze($blob) 			#get the chunklist as an array
	$newblob = zlibshrink($blob)			#attempt to better compress the PNG
	$newblob = filter($blob)			#apply adaptive filtering and then compress
	$newblob = indexcolours($blob)			#attempt to replace RGB IDAT with palette (losslessly)
	$newblob = palettize($blob[, $colourlimit
					[, $dither]])	#replace RGB IDAT with colour index palette (usually lossy)
	\%colourhash = reportcolours($blob)		#return details of the colours in the PNG
	

=head1 DESCRIPTION

Image::Pngslimmer aims to cut down the size of PNGs. Users pass a PNG to various functions 
and a slimmer version is returned. Image::Pngslimmer was designed for use where PNGs are being
generated on the fly and where size matters more than speed- eg for J2ME use or any similiar 
low speed or high latency environment. There are other options - probably better ones - for 
handling static PNGs, though you may still fid the fuctions useful.

Filtering and recompressing an image is not fast - for example on a 4300 BogoMIPS box with 1G
of memory the author processes PNGs at about 30KB per second.

=head2 Functions

Call Image::Pngslimmer::discard_noncritical($blob) on a stream of bytes (eg as created by Perl Magick's
Image::Magick package) to remove sections of the PNG that are not essential for display.

Do not expect this to result in a big saving - the author suggests maybe 200 bytes is typical
- but in an environment such as the backend of J2ME applications that may still be a 
worthwhile reduction.

Image::Pngslimmer::discard_noncritical($blob) will call ispng($blob) before attempting to manipulate the
supplied stream of bytes - hopefully, therefore, avoiding the accidental mangling of 
JPEGs or other files. ispng checks for PNG definition conformity -
it looks for a correct signature, an image header (IHDR) chunk in the right place, looks
for (but does not check in any way) an image data (IDAT) chunk and checks there is an
end (IEND) chunk in the right place. From version 0.03 onwards ispng also checks CRC
values.

Image::Pngslimmer::analyze($blob) is supplied for completeness and to aid debugging. It is not called by 
discard_noncritical but may be used to show 'before-and-after' to demonstrate the savings
delivered by discard_noncritical.

Image::Pngslimmer::zlibshrink($blob) will attempt to better compress the supplied PNG and will achieve good results
with poorly compressed PNGs.

Image::Pngsimmer::filter($blob) will attempt to apply adaptive filtering to the PNG - filtering should deliver 
better compression results (though the results can be mixed).  Please note that filter() will 
compress the image with Z_BEST_SPEED and so the blob returned from the function may even be larger
than the blob passed in. You must call zlibshrink if you want to recompress the blob at maximum level.
All PNG compression and filtering is lossless.

Image::Pngslimmer::indexcolours($blob) will attempt to replace an RGB image with a colourmapped image. NB This is not the
same as quantization - this process is lossless, but also only works if there are less than 256
colours in the image.

Image::Pngslimmer::palettize($blob[, $colourlimit[, $dither]]) will replace a 24 bit RGB image with a colourmapped 
(256 or less colours) image. If the original image has less than $colourlimit colours it will do this by calling 
indexcolours and so losslessly process the image. More generally it will process the image using the lossy median 
cut algorithm. Currently this only works for 24 bit images. Again this process is slow - the author can
process images at about 30 - 50KB per second - meaning it can be used for J2ME in "real time" but is
likely to be too slow for many other dynamic uses. Setting $colourlimit between 1 and 255 allows control over
the size of the generated palette (the default is 0 which generates a 256 colour palette). Setting $dither to
1 will turn on the EXTREMELY SLOW (a 150k image takes over three hours on the author's machine) dithering. It is
not recommended.

$hashref  = Image::Pngslimmer::reportcolours($blob) will return a reference to a hash with a frequency table
of the colours in the image.

=head1 LICENCE AND COPYRIGHT

This is free software and is licenced under the same terms as Perl itself ie Artistic and GPL

It is copyright (c) Adrian McMenamin, 2006, 2007

=head1 REQUIREMENTS

	POSIX
	Compress::Zlib
	Compress::Raw::Zlib

=head1 TODO

To make Pngslimmer really useful it needs to handle a broader range of bit map depths etc. The
work goes on. At the moment it really only works well with 24 bit images (though discard_noncritical
will work with all PNGs).


=head1 AUTHOR

	Adrian McMenamin <adrian AT newgolddream DOT info>

=head1 SEE ALSO

	Image::Magick


=cut