File Coverage

blib/lib/Image/PNG/Rewriter.pm

Criterion	Covered	Total	%
statement	103	115	89.5
branch	22	46	47.8
condition	1	2	50.0
subroutine	18	21	85.7
pod	13	13	100.0
total	157	197	79.7

package Image::PNG::Rewriter;

use 5.010000;
use strict;
use warnings;
use Compress::Zlib qw();
use Carp;
use POSIX qw/ceil/;

our $VERSION = '0.9';
our $PNG_MAGIC = "\x89\x50\x4E\x47\x0D\x0A\x1A\x0A";

require XSLoader;
XSLoader::load('Image::PNG::Rewriter', $VERSION);

use constant CHANNELS => {
  0 => 1,
  2 => 3,
  3 => 1,
  4 => 2,
  6 => 4,
};

sub new {
  my $class = shift;
  my $self = bless {}, $class;
  my %o = @_;
  my $h = $o{handle};

  die "No 'handle' specified" unless $h;

  $o{zlib} //= sub {
    my $data = shift;
    my ($d, $status0) = Compress::Zlib::deflateInit();
    die unless $status0 == Compress::Zlib::Z_OK;
    my ($out1, $status1) = $d->deflate($data);
    die unless $status1 == Compress::Zlib::Z_OK;
    my ($out2, $status2) = $d->flush();
    die unless $status2 == Compress::Zlib::Z_OK;
    return $out1 . $out2;
  };

  $self->{_zlib} = $o{zlib};

  read($h, my $magic, 8) == 8 or die;

  die "Not a PNG image" unless $magic eq $PNG_MAGIC;

  $self->{_chunks} = [];

  while (!eof($h)) {
    # [size] [type] [data] [checksum]
    read($h, my $raw, 8) == 8 or die;
    my ($length, $type) = unpack 'Na4', $raw;
    read($h, my $data, $length) == $length or die;
    read($h, my $crc_raw, 4) == 4 or die;
    my $crc = unpack 'N', $crc_raw;
    push @{ $self->{_chunks} }, {
      type => $type,
      size => $length,
      data => $data,
      crc32 => $crc,
    };
  }

  # get the first IHDR chunk; only one is allowed
  my ($ihdr) = grep { $_->{type} eq 'IHDR' } @{ $self->{_chunks} };
  die unless $ihdr;

  my @ihdr_values = unpack 'NNccccc', $ihdr->{data};
  die unless @ihdr_values == 7;

  ($self->{_width},
   $self->{_height},
   $self->{_depth},
   $self->{_color},
   $self->{_comp},
   $self->{_filter},
   $self->{_interlace}) = @ihdr_values;

  die unless $self->{_width};
  die unless $self->{_height};

  # TODO: validate depth/type restrictions?

  die unless $self->{_comp} == 0;
  die unless $self->{_filter} == 0;

  confess "Interlaced images are not supported"
    if $self->{_interlace};

  $self->{_channels} = (CHANNELS)->{ $self->{_color} };

  die unless defined $self->{_channels};

  # PNGs can have many IDAT chunks
  my $coalesced = join '', map { $_->{data} }
    grep { $_->{type} eq 'IDAT' } @{ $self->{_chunks} };

  # One IEND chunk is required
  die unless 1 == grep { $_->{type} eq 'IEND' }
    @{ $self->{_chunks} };

  my ($i, $status0) = Compress::Zlib::inflateInit;
  die unless $status0 == Compress::Zlib::Z_OK;
  my ($inflated, $status1) = $i->inflate("$coalesced");
  die $status1 unless $status1 == Compress::Zlib::Z_STREAM_END;

  $self->{_inflated} = $inflated;
  $self->{_deflated} = $coalesced;

  $self->{_new_deflated} = "$coalesced";
  $self->{_new_inflated} = "$inflated";

  my $expected_bytes = $self->{_height} *
    ceil(($self->{_width} * $self->{_channels} * $self->{_depth} + 8) / 8);

  my $actual_bytes = length $self->{_inflated};
  die unless $expected_bytes == $actual_bytes;

  $self->{_scanline_width} = $expected_bytes / $self->{_height};
  $self->{_scanline_delta} = $self->{_channels} * ceil($self->{_depth} / 8);

  # Destructive operation needs a copy
  $self->{_unfiltered} = "$inflated";
  _unfilter($self->{_unfiltered}, $self->{_height}, $self->{_scanline_delta}, $self->{_scanline_width});

  $self;
}

sub refilter {
  my $self = shift;
  my @filters = @_;
  die unless @filters == $self->height;

  $self->{_new_inflated} = $self->{_unfiltered} . "";
  my $filter = join '', map chr, @filters;

  _filter($self->{_unfiltered}, $self->{_new_inflated},
    $filter, $self->{_height}, $self->{_scanline_delta},
    $self->{_scanline_width});

  $self->{_new_filters} = \@filters;
  $self->{_new_deflated} = $self->{_zlib}->($self->{_new_inflated});
  return $self->{_new_deflated}, $self->{_new_inflated};
}

sub as_png {
  my $self = shift;
  my @other_chunks =
    grep { $_->{type} ne 'IDAT' } $self->original_chunks;
  my $data = $self->{_new_deflated};

  my $idat = { type => 'IDAT', data => $data,
    crc32 => Compress::Zlib::crc32("IDAT$data") };

  my @chunks = map {
    pack('Na4', length $_->{data}, $_->{type})
      . $_->{data} . pack('N', $_->{crc32})
  } map {
    $_->{type} eq 'IEND' ? ($idat, $_) : $_
  } @other_chunks;

  return $PNG_MAGIC . join '', @chunks;
}

sub original_filters {
  my $self = shift;
  map { ord(substr $self->{_inflated},
    $_ * $self->{_scanline_width}, 1) }
    0 .. $self->{_height} - 1;
}

sub original_chunks { @{ $_[0]->{_chunks} } }
sub original_inflated { $_[0]->{_inflated} }
sub original_deflated { $_[0]->{_deflated} }
sub width { $_[0]->{_width} }
sub height { $_[0]->{_height} }
sub color_mode { $_[0]->{_color} }
sub depth { $_[0]->{_depth} }

sub scanline_width { $_[0]->{_scanline_width} }
sub scanline_delta { $_[0]->{_scanline_delta} }

1;

__END__