File Coverage

blib/lib/Image/Pngslimmer.pm

Criterion	Covered	Total	%
statement	814	974	83.5
branch	176	300	58.6
condition	28	39	71.7
subroutine	42	44	95.4
pod	0	38	0.0
total	1060	1395	75.9

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.30';

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 ( $pngsig, $startpng, $ihdr_len, $pnglength, $searchindex );
    my ( $idatfound, $nextindex );
    my $blob = shift;

    #check for signature
    $pngsig = pack( "C8", ( 137, 80, 78, 71, 13, 10, 26, 10 ) );
    $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;
    }
    $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
    $pnglength = length($blob);

    #start searching from end of IHDR chunk
    $searchindex = 16 + $ihdr_len + 4 + 4;
    $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;
        }
        $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 ( $bitblob, $blobout, $status, $y );
    my ( $blobin, $strategy, $level ) = @_;
    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 );
    my ( $calc_crc, $uncompcrc, $searchindex );
    my ( $chunklength, $numberofidats, $chunknumber, $outlength );
    my $blobin    = shift;
    my $pnglength = length($blobin);
    $searchindex = 8 + 25;    #start looking at the end of the IHDR
    while ( $searchindex < ( $pnglength - 8 ) ) {
        $chunklength = unpack( "N", substr( $blobin, $searchindex, 4 ) );
        if ( substr( $blobin, $searchindex + 4, 4 ) eq "IDAT" ) {
            push( @idats, $searchindex );
        }
        $searchindex += $chunklength + 12;
    }
    $numberofidats = @idats;
    if ( $numberofidats == 0 ) {
        return undef;
    }
    $chunknumber = 0;
    while ( $chunknumber < $numberofidats ) {
        $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;
    $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, $blobin ) = @_;
    my $output = getuncompressed_data($blobin);
    unless ( defined($output) ) {
        return $chunkin;
    }
    my $rawlength = length($output);
    my $purecrc   = adler32($output);

    # now crush it at the maximum level
    my $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
    my $chunkout = pack( "N", $newlength );
    my $rfc1950stuff = pack( "C2", ( 0x78, 0xDA ) );
    my $output2 = "IDAT" . $rfc1950stuff . $crusheddata . pack( "N", $purecrc );
    my $outcrc = crc32($output2);
    $chunkout = $chunkout . $output2 . pack( "N", $outcrc );
    return $chunkout;
}

sub zlibshrink {
    my $chunktocopy;
    my ( $chunklength, $processedchunk, $lenidat );
    my $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;
    }
    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 $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 = "";
            }
        }

        $lenidat = length($chunktocopy);
        $blobout = $blobout . $chunktocopy;
        $searchindex += $chunklength + 12;
    }
    return $blobout;
}

sub linebyline {

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

            #already filtered
            $return_filtered = -1;
            last;
        }
        $count++;
    }
    return $return_filtered;    #can be filtered?
}

sub comp_width {

    # ctypes:
    # 0: greyscale
    # 2: truecolour
    # 3: indexed-colour
    # 4: greyscale plus alpha
    # 6: truecolour plus alpha

    my $ihdr       = shift;
    my $comp_width = 3;
    my $alpha      = 0;
    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 ) {
        if ( $bdepth == 16 ) {

            #16 bit greyscale
            $comp_width = 2;
        }
        elsif ( $bdepth == 8 ) {

            #8 bit greyscale
            $comp_width = 1;
        }

        #less than a byte greyscale
        elsif ( $bdepth == 4 ) {
            $comp_width = 0.5;
        }
        elsif ( $bdepth == 2 ) {
            $comp_width = 0.25;
        }
        elsif ( $bdepth == 1 ) {
            $comp_width = 0.125;
        }
    }
    elsif ( $ctype == 4 ) {    #grayscale with alpha
        $alpha = 1;
        if ( $bdepth == 8 ) {
            $comp_width = 2;
        }
        else {
            $comp_width = 4;
        }
    }
    elsif ( $ctype == 6 ) {    #truecolour with alpha
        $alpha = 1;
        if ( $bdepth == 8 ) {
            $comp_width = 4;
        }
        else {
            $comp_width = 8;
        }
    }

    return ( $comp_width, $alpha );
}

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 );
    my $unfiltereddata = shift;
    my $ihdr           = shift;
    my $count          = 0;
    my $count_width    = 0;
    my $newbyte        = 0;
    my ( $comp_width, $alpha ) = comp_width($ihdr);
    my $totalwidth   = $ihdr->{"imagewidth"} * $comp_width;
    my $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 );
    my $unfiltereddata = shift;
    my $ihdr           = shift;
    my ( $comp_width, $alpha ) = comp_width($ihdr);
    my $count        = 0;
    my $count_width  = 0;
    my $newbyte      = 0;
    my $totalwidth   = $ihdr->{"imagewidth"} * $comp_width;
    my $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 );
    my ( $top_predictor, $left_predictor );
    my $unfiltereddata = shift;
    my $ihdr           = shift;
    my ( $comp_width, $alpha ) = comp_width($ihdr);
    my $count        = 0;
    my $count_width  = 0;
    my $newbyte      = 0;
    my $totalwidth   = $ihdr->{"imagewidth"} * $comp_width;
    my $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 );
    my ( $paeth_pa, $paeth_pb, $paeth_pc, $paeth_predictor );
    my $unfiltereddata = shift;
    my $ihdr           = shift;
    my ( $comp_width, $alpha ) = comp_width($ihdr);
    my $count        = 0;
    my $count_width  = 0;
    my $newbyte      = 0;
    my $totalwidth   = $ihdr->{"imagewidth"} * $comp_width;
    my $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 ( $filtereddata, $finalfiltered );
    my $unfiltereddata = shift;
    my $ihdr           = shift;
    my $filtered_sub   = filter_sub( $unfiltereddata, $ihdr );
    my $filtered_up    = filter_up( $unfiltereddata, $ihdr );
    my $filtered_ave   = filter_ave( $unfiltereddata, $ihdr );
    my $filtered_paeth = filter_paeth( $unfiltereddata, $ihdr );

    my $pixels = $ihdr->{"imagewidth"};
    my $rows   = $ihdr->{"imageheight"};
    my ( $comp_width, $alpha ) = 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 %ihdr;
    my $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 ( $chunklength, $chunktocopy, $rfc1950stuff, $output, $newlength );
    my ( $outcrc, $processedchunk, $filtereddata );
    my $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 ) {

        #already palettized
        return $blobin;
    }
    if ( $ihdr->{"bitdepth"} < 8 ) {

        #colour depth too low to be worth it
        return $blobin;
    }
    if ( $ihdr->{"compression"} != 0 ) {

        #non-standard compression
        return $blobin;
    }
    if ( $ihdr->{"filter"} != 0 ) {

        #non-standard filtering
        return $blobin;
    }
    if ( $ihdr->{"interlace"} != 0 ) {

        #FIXME: support interlacing
        return $blobin;
    }
    my $datachunk = getuncompressed_data($blobin);
    unless ( defined($datachunk) ) {
        return $blobin;
    }
    my $canfilter = linebyline( $datachunk, $ihdr );
    if ( $canfilter > 0 ) {
        $filtereddata = filterdata( $datachunk, $ihdr );
    }
    else {
        return $blobin;
    }

    #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
        $chunklength = unpack( "N", substr( $blobin, $searchindex - 4, 4 ) );
        $chunktocopy = substr( $blobin, $searchindex - 4, $chunklength + 12 );
        if ( substr( $blobin, $searchindex, 4 ) eq "IDAT" ) {
            if ( $foundidat == 0 ) {

                #ignore any additional IDAT chunks
                $rfc1950stuff = pack( "C2", ( 0x78, 0x5E ) );
                $output = "IDAT"
                  . $rfc1950stuff
                  . $filtereddata
                  . pack( "N", $filteredcrc );
                $newlength = $filterlen + 6;
                $outcrc    = crc32($output);
                $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 $chunktext;
    my $nextindex;
    my $blob = shift;
    if ( ispng($blob) < 1 ) {

        #not a PNG
        return $blob;
    }

    #we know we have a png = so go straight to the IHDR chunk
    #copy signature and text + length from IHDR
    my $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
    my $searchindex = 16 + $ihdr_len + 8;
    my $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 = shift;
    my $ihdr   = getihdr($blobin);
    return 0 unless $ihdr->{"colourtype"} == 3;
    return 1;
}

sub unfiltersub {
    my $lineout;
    my ( $addition, $reconbyte );
    my ( $chunkin, $lines_done, $linelength, $comp_width ) = @_;
    my $pointis = 1;
    while ( $pointis < $linelength ) {
        $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 $lineout;
    my ( $addition, $reconbyte );
    my ( $chunkin, $chunkout, $lines_done, $linelength ) = @_;
    my $pointis = 1;
    while ( $pointis < $linelength ) {
        $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 $lineout;
    my ( $addition, $addition_up, $addition_left );
    my $reconbyte;
    my ( $chunkin, $chunkout, $lines_done, $linelength, $compwidth ) = @_;
    my $pointis = 1;
    while ( $pointis < $linelength ) {
        $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 $lineout;
    my ( $addition, $addition_up, $addition_left );
    my ( $addition_uleft, $reconbyte, $paeth_p, $paeth_a, $paeth_b );
    my ( $paeth_c, $recbyte );
    my ( $chunkin, $chunkout, $lines_done, $linelength, $compwidth ) = @_;
    my $pointis = 1;
    while ( $pointis < $linelength ) {
        $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;
        }
        $paeth_p = $addition_up + $addition_left - $addition_uleft;
        $paeth_a = abs( $paeth_p - $addition_left );
        $paeth_b = abs( $paeth_p - $addition_up );
        $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;
        }
        $recbyte = ( $reconbyte + $addition ) % 256;
        $lineout = $lineout . pack( "C", $recbyte );
        $pointis++;
    }
    $lineout = "\0" . $lineout;
    return $lineout;
}

sub unfilter {
    my $chunkout;
    my $filtertype;
    my $chunkin     = shift;
    my $ihdr        = shift;
    my $imageheight = $ihdr->{"imageheight"};
    my $imagewidth  = $ihdr->{"imagewidth"};

    #get each line
    my $lines_done  = 0;
    my $pixels_done = 0;
    my ( $comp_width, $alpha ) = comp_width($ihdr);
    my $linelength = $comp_width * $imagewidth + 1;
    while ( $lines_done < $imageheight ) {
        $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 ( $limit, $totallines, $width );
    my ( $cdepth, $x, $colourfound, $pixelpoint, $colour, $alpha, $ndepth );
    my %colourlist;
    my $bdepth;
    my ( $chunk, $ihdr ) = @_;
    $totallines = $ihdr->{"imageheight"};
    $width      = $ihdr->{"imagewidth"};
    ( $cdepth, $alpha ) = comp_width($ihdr);
    my $linesdone    = 0;
    my $linelength   = $width * $cdepth + 1;
    my $coloursfound = 0;
    $ndepth = $cdepth;

    if ($alpha) {

        #truecolour first
        if ( $cdepth == 4 ) {
            $bdepth = $ihdr->{"bitdepth"};
            if ( $bdepth == 8 ) {
                $ndepth = 3;
            }
            else {
                $ndepth = 2;
            }
        }
        elsif ( $cdepth == 8 ) {
            $ndepth = 6;
        }

        #now greyscale
        elsif ( $cdepth == 2 ) {
            $ndepth = 1;
        }
    }
    while ( $linesdone < $totallines ) {
        $pixelpoint = 0;
        while ( $pixelpoint < $width ) {
            $colourfound =
              substr( $chunk,
                ( $pixelpoint * $cdepth ) + ( $linesdone * $linelength ) + 1,
                $ndepth );
            $colour = 0;
            for ( $x = 0 ; $x < $ndepth ; $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 $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;
    }
    my $filtereddata   = getuncompressed_data($blobin);
    my $ihdr           = getihdr($blobin);
    my $unfiltereddata = unfilter( $filtereddata, $ihdr );
    my ( $colours, $colourlist ) = countcolours( $unfiltereddata, $ihdr );
    return $colourlist;
}

sub indexcolours {

    # take PNG and count colours
    my $blobout;
    my ( $ihdr_chunk, $pal_chunk, $x, $palindex, $colourfound );
    my $ihdrcrc;
    my ( $searchindex, $pnglength, $foundidat, $chunklength, $chunktocopy );
    my ( $palcount, $pal_crc, $len_pal, $dataout, $linesdone, $totallines );
    my ( $width, $cdepth, $linelength, $pixelpoint, $colour, $rfc1950stuff );
    my ( $rfc1951stuff, $output, $newlength, $outcrc, $processedchunk );
    my ( $alpha, $ndepth, $bdepth );

    my $blobin = shift;

    #is it a PNG
    return $blobin unless ispng($blobin) > 0;

    #is it already palettized?
    return $blobin unless ispalettized($blobin) < 1;
    my $colour_limit = shift;

    #0 means no limit
    $colour_limit = 0 unless $colour_limit;
    my $filtereddata   = getuncompressed_data($blobin);
    my $ihdr           = getihdr($blobin);
    my $unfiltereddata = unfilter( $filtereddata, $ihdr );
    my ( $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"} ) );

        #FIXME: Support index of less than 8 bits
        #8 bit indexed colour
        $ihdr_chunk = $ihdr_chunk . pack( "C2", ( 8, 3 ) );
        $ihdr_chunk = $ihdr_chunk
          . pack( "C3",
            ( $ihdr->{"compression"}, $ihdr->{"filter"}, $ihdr->{"interlace"} )
          );
        $ihdrcrc = crc32($ihdr_chunk);
        $blobout = $blobout . $ihdr_chunk . pack( "N", $ihdrcrc );

        #now any chunk before the IDAT
        $searchindex = 16 + 13 + 4 + 4;
        $pnglength   = length($blobin);
        $foundidat   = 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 ( $foundidat == 0 ) {

                    #ignore any additional IDAT chunks
                    #now the palette chunk
                    $pal_chunk = "";
                    my %colourlist = %{$colourlist};
                    $palcount = 0;
                    my %palindex;
                    my @keyslist = keys(%colourlist);
                    keys(%palindex) = scalar(@keyslist);
                    foreach $x (@keyslist) {
                        $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++;
                    }
                    $pal_crc = crc32( "PLTE" . $pal_chunk );
                    $len_pal = length($pal_chunk);
                    $blobout = $blobout
                      . pack( "N", $len_pal ) . "PLTE"
                      . $pal_chunk
                      . pack( "N", $pal_crc );

                    #now process the IDAT
                    $linesdone  = 0;
                    $totallines = $ihdr->{"imageheight"};
                    $width      = $ihdr->{"imagewidth"};
                    ( $cdepth, $alpha ) = comp_width($ihdr);
                    $ndepth = $cdepth;

                    if ($alpha) {

                        #truecolour first
                        if ( $cdepth == 4 ) {
                            $bdepth = $ihdr->{"bitdepth"};
                            if ( $bdepth == 8 ) {
                                $ndepth = 3;
                            }
                            else {
                                $ndepth = 2;
                            }
                        }
                        elsif ( $cdepth == 8 ) {
                            $ndepth = 6;
                        }

                        #now greyscale
                        elsif ( $cdepth == 2 ) {
                            $ndepth = 1;
                        }
                    }

                    $linelength = $width * $cdepth + 1;
                    while ( $linesdone < $totallines ) {
                        $dataout    = $dataout . "\0";
                        $pixelpoint = 0;
                        while ( $pixelpoint < $width ) {
                            $colourfound = substr(
                                $unfiltereddata,
                                ( $pixelpoint * $cdepth ) +
                                  ( $linesdone * $linelength ) + 1,
                                $ndepth
                            );
                            $colour = 0;
                            for ( $x = 0 ; $x < $ndepth ; $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

                    $rfc1950stuff = pack( "C2", ( 0x78, 0x5E ) );
                    $rfc1951stuff =
                      shrinkchunk( $dataout, Z_DEFAULT_STRATEGY, Z_BEST_SPEED );
                    $output = "IDAT"
                      . $rfc1950stuff
                      . $rfc1951stuff
                      . pack( "N", adler32($dataout) );
                    $newlength = length($output) - 4;
                    $outcrc    = crc32($output);
                    $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, $numb, $x, $rt, $gt, $bt );
    my $coloursin = shift;
    $numb = scalar(@$coloursin);
    if ( $numb == 0 ) { return ( 0, 0, 0 ) }
    for ( $x = 0 ; $x < $numb ; $x++ ) {
        ( $rt, $gt, $bt ) = convert_toxyz( $coloursin->[$x] );
        $red   += $rt;
        $green += $gt;
        $blue  += $bt;
    }
    $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 ( $longestaxis, $length, $i, );
    my $boundingbox = shift;
    return ( 0, 0 ) unless defined( $boundingbox->[5] );
    $longestaxis = 0;
    my @lengths = (
        $boundingbox->[3] - $boundingbox->[0],
        $boundingbox->[4] - $boundingbox->[1],
        $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, $n ) = @_;
    my $index = 0;
    my $length;
    my $biggest = $boxesin->[3];
    if ($n > 1) {
	for ( my $i = 1 ; $i < $n ; $i++ ) {

            #length is 4th item per box
	    $length = $boxesin->[ $i * 4 + 3 ];
	    if ($length > $biggest) {
	    	$index = $i;
		$biggest = $length;
	    }
	}
    }
    return $index;
}

sub sortonaxes {
    my ( $coloursref, $longestaxis ) = @_;
    my @newcolours = @$coloursref;

    #FIXME: This only works for 24 bit colour
    if ( $longestaxis == 2 ) {

        #can just sort on the whole number if red
        return [sort { $a <=> $b } @newcolours];
    }
    my $colshift = 0xFFFFFF >> ( 16 - ( $longestaxis * 8 ) );
    my ( $x, %distances );
    keys(%distances) = scalar(@newcolours);
    foreach $x (@newcolours) {
        $distances{$x} = $x & $colshift;
    }
    return [sort { $distances{$a} <=> $distances{$b} } keys %distances];
}

sub generate_box {

    #convert colours to cartesian points
    #and then return the bounding box
    if ( scalar(@_) == 1 ) {
        return [ convert_toxyz( pop @_ ) ];
    }
    my ( @reds, @greens, @blues );
    my ( $x, $rd, $gn, $bl, $boundref );
    foreach $x (@_) {
        ( $rd, $gn, $bl ) = convert_toxyz($x);
        push @reds,   $rd;
        push @greens, $gn;
        push @blues,  $bl;
    }
    @reds   = sort { $a <=> $b } @reds;
    @greens = sort { $a <=> $b } @greens;
    @blues  = sort { $a <=> $b } @blues;
    $boundref = [
        shift @reds,
        shift @greens,
        shift @blues,
        pop @reds,
        pop @greens,
        pop @blues
    ];
    return $boundref;
}

sub getpalette {
    my ( $x, @palette, %lookup, $lookup, $boxes, $z );
    my ( $colnumbers, $colours );
    my @boxes = @_;

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

sub closestmatch_inRGB {
    my ( $colourin, $pr, $pg, $pb );
    my ( $maxindex, $x, $q );
    my ( $index, $distance, $newdistance );

    $distance = 0xFFFFF;
    my ( $palref, $cir, $cig, $cib ) = @_;
    my @pallist = @$palref;
    $maxindex = scalar(@pallist) / 3;    # assuming three colours
    $q = 0;
    for ( $x = 0 ; $x < $maxindex ; $x++ ) {
        $pr = $pallist[ $q++ ] - $cir;
        $pg = $pallist[ $q++ ] - $cig;
        $pb = $pallist[ $q++ ] - $cib;
        $newdistance = $pr * $pr + $pg * $pg + $pb * $pb;
        if ( $newdistance < $distance ) {
            $distance = $newdistance;
            $index    = $x;

            #approximate
            if ( $distance <= 12 ) { last }
        }
    }
    return $index;
}

sub index_mediancut {
    my $colour_numbers;
    my ( @boundingbox,   $colcount, @boxes );
    my ( $boxtocut,      $median,   $biggestbox );
    my ( $sortedcolours, $boxout,   $refbigbox );
    my ( $colourlist, $colourspaces ) = @_;
    if ( !defined($colourspaces) || ( $colourspaces == 0 ) ) {
        $colourspaces = 256;
    }
    $colcount = 0;
    my %colourlist = %{$colourlist};
    my @colourkeys = keys(%colourlist);

    #can now define the colour space
    # boxes data is
    # reftoboundingboxarray, reftocoloursarray, longest_axis,
    # length_of_longest_axis
    $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;
        my @biggestbox = splice( @boxes, $boxtocut * 4, 4 );

        #now sort on the axis
        $sortedcolours = sortonaxes( $biggestbox[1], $biggestbox[2] );
        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 ( $linelength, $rcomp, $gcomp, $bcomp,     $palnumber );
    my ( $rp,         $rg,    $rb,    $max_value, $currentoffset_w );
    my ( $currentoffset_h, $nextoffset_h, $ll );

    my (
        $colour,    $unfiltereddata, $cdepth,     $ndepth,
        $linesdone, $pixelpoint,     $totallines, $pallookref,
        $paloutref, $pal_chunk,      $width
    ) = @_;
    $linelength = $width * $cdepth + 1;

    #FIXME not just 24 bit depth
    ( $rcomp, $gcomp, $bcomp ) = convert_toxyz($colour);
    $palnumber = $pallookref->{$colour};
    if ( !$palnumber ) {
        $palnumber = closestmatch_inRGB( $paloutref, $rcomp, $gcomp, $bcomp );
    }

    ( $rp, $rg, $rb ) = unpack( "C3", substr( $pal_chunk, $palnumber * 3, 3 ) );

    #calculate the errors
    my @colerror = ( $rcomp - $rp, $gcomp - $rg, $bcomp - $rb );

    #now diffuse the errors
    if ( $cdepth >= 6 ) {
        $max_value = 0xFFFF;
    }
    else {
        $max_value = 0xFF;
    }
    $currentoffset_w = $pixelpoint * $cdepth;
    $currentoffset_h = $linesdone * $linelength;
    $nextoffset_h    = ( $linesdone + 1 ) * $linelength;
    for ( $ll = 0 ; $ll < $ndepth ; $ll++ ) {
        if ( $colerror[$ll] == 0 ) {
            next;
        }
        my $sign = 1;
        if ( $colerror[$ll] < 1 ) {
            $sign = -1;
            $colerror[$ll] = abs( $colerror[$ll] );
        }
        if ( ( $pixelpoint + 1 ) < $width ) {
            my $unpacked = unpack(
                "C",
                substr(
                    $unfiltereddata,
                    $currentoffset_w + $currentoffset_h + 1 + $cdepth + $ll, 1
                )
            );

            $unpacked += ( ( $colerror[$ll] * 7 ) >> 4 ) * $sign;
            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] >> 4 ) * $sign;
                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 ) {
            my $unpacked = unpack(
                "C",
                substr(
                    $unfiltereddata, $currentoffset_w + $nextoffset_h + 1 + $ll,
                    1
                )
            );
            $unpacked += ( ( $colerror[$ll] * 5 ) >> 4 ) * $sign;
            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 ) >> 4 ) * $sign;
                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 ( $pal_chunk, $x, $colourfound );
    my $palnumb;
    my ( $chunklength, $chunktocopy );
    my ( $palcount, $pal_crc, $len_pal, $dataout, $linesdone, $totallines );
    my ( $width, $linelength, $colour, $palnumber );
    my ( $pixelpoint, $linemarker, $rfc1950stuff, $rfc1951stuff, $output );
    my ( $newlength, $outcrc, $processedchunk );
    my $bdepth;

    my $blobin = shift;

    #is it a PNG
    return $blobin unless ispng($blobin) > 0;

    #is it already palettized?
    return $blobin unless ispalettized($blobin) < 1;
    my $colour_limit = shift;

    #0 means no limit
    $colour_limit = 0 unless $colour_limit;
    my $dither = shift;
    $dither = 0 unless $dither;
    my $filtereddata   = getuncompressed_data($blobin);
    my $ihdr           = getihdr($blobin);
    my $unfiltereddata = unfilter( $filtereddata, $ihdr );
    my ( $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;
    }
    my ( $paloutref, $pallookref ) =
      index_mediancut( $colourlist, $colour_limit );

    #have to rewrite the whole thing now
    #start with the PNG header
    my $blobout = pack( "C8", ( 137, 80, 78, 71, 13, 10, 26, 10 ) );

    my ( $cdepth, $alpha ) = comp_width($ihdr);
    my $ndepth = $cdepth;
    if ($alpha) {

        #truecolour first
        if ( $cdepth == 4 ) {
            $bdepth = $ihdr->{"bitdepth"};
            if ( $bdepth == 8 ) {
                $ndepth = 3;
            }
            else {
                $ndepth = 2;
            }
        }
        elsif ( $cdepth == 8 ) {
            $ndepth = 6;
        }

        #now greyscale
        elsif ( $cdepth == 2 ) {
            $ndepth = 1;
        }
    }

    #now the IHDR
    $blobout = $blobout . pack( "N", 0x0D );
    my $ihdr_chunk = "IHDR";
    $ihdr_chunk = $ihdr_chunk
      . pack( "N2", ( $ihdr->{"imagewidth"}, $ihdr->{"imageheight"} ) );

    #FIXME: 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
        $chunklength = unpack( "N", substr( $blobin, $searchindex - 4, 4 ) );
        $chunktocopy = substr( $blobin, $searchindex - 4, $chunklength + 12 );
        if ( substr( $blobin, $searchindex, 4 ) eq "IDAT" ) {
            if ( $foundidat == 0 ) {    #ignore any additional IDATs
                                        #now the palette chunk
                $pal_chunk = "";
                my @colourlist = @$paloutref;
                $palcount = 0;
                foreach $x (@colourlist) {
                    $pal_chunk = $pal_chunk . pack( "C", $x );
                }
                $pal_crc = crc32( "PLTE" . $pal_chunk );
                $len_pal = length($pal_chunk);
                $blobout = $blobout
                  . pack( "N", $len_pal ) . "PLTE"
                  . $pal_chunk
                  . pack( "N", $pal_crc );

                #now process the IDAT
                $linesdone  = 0;
                $totallines = $ihdr->{"imageheight"};
                $width      = $ihdr->{"imagewidth"};

                $linelength = $width * $cdepth + 1;
                my %colourlookup = %{$pallookref};
                while ( $linesdone < $totallines ) {
                    $dataout    = $dataout . "\0";
                    $pixelpoint = 0;
                    $linemarker = $linesdone * $linelength + 1;
                    while ( $pixelpoint < $width ) {
                        $colourfound =
                          substr( $unfiltereddata,
                            ( $pixelpoint * $cdepth ) + $linemarker, $ndepth );
                        $colour = 0;
                        for ( $x = 0 ; $x < $ndepth ; $x++ ) {
                            $colour =
                              ( $colour << 8 |
                                  ord( substr( $colourfound, $x, 1 ) ) );
                        }
                        if ( $dither == 1 ) {

                            #add the new
                            #match to
                            #the palette if
                            #required
                            ( $palnumb, $unfiltereddata ) = dither(
                                $colour,     $unfiltereddata, $cdepth,
                                $ndepth,     $linesdone,      $pixelpoint,
                                $totallines, \%colourlookup,  $paloutref,
                                $pal_chunk,  $width
                            );
                            if ( !$colourlookup{$colour} ) {
                                $colourlookup{$colour} = $palnumb;
                            }
                        }
                        $dataout =
                          $dataout . pack( "C", $colourlookup{$colour} );
                        $pixelpoint++;
                    }
                    $linesdone++;
                }

                #now to deflate $dataout to get proper stream
                $rfc1950stuff = pack( "C2", ( 0x78, 0x5E ) );
                $rfc1951stuff =
                  shrinkchunk( $dataout, Z_DEFAULT_STRATEGY, Z_BEST_SPEED );
                $output = "IDAT"
                  . $rfc1950stuff
                  . $rfc1951stuff
                  . pack( "N", adler32($dataout) );
                $newlength = length($output) - 4;
                $outcrc    = crc32($output);
                $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 ( $chunk_desc, $chunk_text, $chunk_length, $chunk_crc );
    my ( $crit_status, $pub_status, @chunk_array, $searchindex, $pnglength );
    my ( $chunk_crc_checked, $nextindex );
    my $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__