File Coverage

blib/lib/PDF/API2/Resource/XObject/Image/PNG.pm

Criterion	Covered	Total	%
statement	150	268	55.9
branch	46	74	62.1
condition	16	39	41.0
subroutine	14	14	100.0
pod	1	3	33.3
total	227	398	57.0

package PDF::API2::Resource::XObject::Image::PNG;

use base 'PDF::API2::Resource::XObject::Image';

use strict;
use warnings;

our $VERSION = '2.043'; # VERSION

use Compress::Zlib;
use POSIX qw(ceil floor);

use IO::File;
use PDF::API2::Util;
use PDF::API2::Basic::PDF::Utils;
use Scalar::Util qw(weaken);

eval 'use PDF::API2::XS::ImagePNG';
my $use_xs = $@ ? 0 : 1;

sub new {
    my ($class, $pdf, $file, $name, %opts) = @_;
    my $self;

    $class = ref($class) if ref($class);

    $self = $class->SUPER::new($pdf, $name || 'Px' . pdfkey());
    $pdf->new_obj($self) unless $self->is_obj($pdf);

    $self->{' apipdf'} = $pdf;
    weaken $self->{' apipdf'};

    my $fh = IO::File->new();
    if (ref($file)) {
        $fh = $file;
    }
    else {
        open $fh, '<', $file or die "$!: $file";
    }
    binmode $fh, ':raw';

    my ($buf, $l, $crc, $w, $h, $bpc, $cs, $cm, $fm, $im, $palette, $trns);
    seek($fh, 8, 0);
    $self->{' stream'} = '';
    $self->{' nofilt'} = 1;
    while (!eof($fh)) {
        read($fh, $buf, 4);
        $l = unpack('N', $buf);
        read($fh, $buf, 4);
        if ($buf eq 'IHDR') {
            read($fh, $buf, $l);
            ($w, $h, $bpc, $cs, $cm, $fm, $im) = unpack('NNCCCCC', $buf);
            die "Unsupported Compression($cm) Method" if $cm;
            die "Unsupported Interlace($im) Method"   if $im;
            die "Unsupported Filter($fm) Method"      if $fm;
        }
        elsif ($buf eq 'PLTE') {
            read($fh, $buf, $l);
            $palette = $buf;
        }
        elsif ($buf eq 'IDAT') {
            read($fh, $buf, $l);
            $self->{' stream'} .= $buf;
        }
        elsif ($buf eq 'tRNS') {
            read($fh, $buf, $l);
            $trns = $buf;
        }
        elsif ($buf eq 'IEND') {
            last;
        }
        else {
            # skip ahead
            seek($fh, $l, 1);
        }
        read($fh, $buf, 4);
        $crc = $buf;
    }
    close $fh unless ref($file);

    $self->width($w);
    $self->height($h);

    # BPC = bits per component, and may be 1, 2, 4, 8, or 16 per the PNG spec.
    # Color types may further restrict the available options.  Additionally,
    # this module doesn't currently support 16-bit components.
    if ($bpc == 16) {
        die '16-bit colors/transparency are not supported.';
    }
    unless ($bpc == 1 or $bpc == 2 or $bpc == 4 or $bpc == 8) {
        die "Invalid component bit depth: $bpc.";
    }

    # Grayscale
    if ($cs == 0) {
        $self->filters('FlateDecode');
        $self->colorspace('DeviceGray');
        $self->bpc($bpc);
        my $dict = PDFDict();
        $self->{'DecodeParms'} = PDFArray($dict);
        $dict->{'Predictor'} = PDFNum(15);
        $dict->{'BitsPerComponent'} = PDFNum($bpc);
        $dict->{'Colors'} = PDFNum(1);
        $dict->{'Columns'} = PDFNum($w);
        if (defined $trns and not $opts{'-notrans'}) {
            my $m = mMax(unpack('n*', $trns));
            my $n = mMin(unpack('n*', $trns));
            $self->{'Mask'} = PDFArray(PDFNum($n), PDFNum($m));
        }
    }

    # RGB
    elsif ($cs == 2) {
        $self->filters('FlateDecode');
        $self->colorspace('DeviceRGB');
        $self->bpc($bpc);
        my $dict = PDFDict();
        $self->{'DecodeParms'} = PDFArray($dict);
        $dict->{'Predictor'} = PDFNum(15);
        $dict->{'BitsPerComponent'} = PDFNum($bpc);
        $dict->{'Colors'} = PDFNum(3);
        $dict->{'Columns'} = PDFNum($w);
        if (defined $trns and not $opts{'-notrans'}) {
            my @v = unpack('n*', $trns);
            my (@cr, @cg, @cb, $m, $n);
            while (scalar @v > 0) {
                push @cr, shift(@v);
                push @cg, shift(@v);
                push @cb, shift(@v);
            }
            @v = ();
            $m = mMax(@cr);
            $n = mMin(@cr);
            push @v, $n, $m;
            $m = mMax(@cg);
            $n = mMin(@cg);
            push @v, $n, $m;
            $m = mMax(@cb);
            $n = mMin(@cb);
            push @v, $n, $m;
            $self->{'Mask'} = PDFArray(map { PDFNum($_) } @v);
        }
    }

    # Palette Index
    elsif ($cs == 3) {
        my $dict = PDFDict();
        $pdf->new_obj($dict);
        $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
        $dict->{' stream'} = $palette;
        $palette = '';
        $self->filters('FlateDecode');
        $self->colorspace(PDFArray(PDFName('Indexed'), PDFName('DeviceRGB'), PDFNum(int(length($dict->{' stream'}) / 3) - 1), $dict));
        $self->bpc($bpc);
        $dict = PDFDict();
        $self->{'DecodeParms'} = PDFArray($dict);
        $dict->{'Predictor'} = PDFNum(15);
        $dict->{'BitsPerComponent'} = PDFNum($bpc);
        $dict->{'Colors'} = PDFNum(1);
        $dict->{'Columns'} = PDFNum($w);
        if (defined $trns and not $opts{'-notrans'}) {
            $trns .= "\xFF" x 256;
            $dict = PDFDict();
            $pdf->new_obj($dict);
            $dict->{'Type'} = PDFName('XObject');
            $dict->{'Subtype'} = PDFName('Image');
            $dict->{'Width'} = PDFNum($w);
            $dict->{'Height'} = PDFNum($h);
            $dict->{'ColorSpace'} = PDFName('DeviceGray');
            $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
            $dict->{'BitsPerComponent'} = PDFNum(8);
            $self->{'SMask'} = $dict;
            my $scanline = 1 + ceil($bpc * $w / 8);
            my $bpp = ceil($bpc / 8);
            my $clearstream = unprocess($bpc, $bpp, 1, $w, $h, $scanline, \$self->{' stream'}, $file);
            foreach my $n (0 .. ($h * $w) - 1) {
                vec($dict->{' stream'}, $n, 8) = vec($trns, vec($clearstream, $n, $bpc), 8);
            }
        }
    }

    # Grayscale + Alpha
    elsif ($cs == 4) {
        $self->filters('FlateDecode');
        $self->colorspace('DeviceGray');
        $self->bpc($bpc);
        my $dict = PDFDict();
        $self->{'DecodeParms'} = PDFArray($dict);
        $dict->{'BitsPerComponent'} = PDFNum($bpc);
        $dict->{'Colors'} = PDFNum(1);
        $dict->{'Columns'} = PDFNum($w);

        # The unprocess call below removes the PNG optimizations, so use the
        # default Predictor (none) instead of PNG optimized (15), as in other
        # color types.
        #
        # $dict->{'Predictor'} = PDFNum(15);

        $dict = PDFDict();
        unless ($opts{'-notrans'}) {
            $pdf->new_obj($dict);
            $dict->{'Type'}             = PDFName('XObject');
            $dict->{'Subtype'}          = PDFName('Image');
            $dict->{'Width'}            = PDFNum($w);
            $dict->{'Height'}           = PDFNum($h);
            $dict->{'ColorSpace'}       = PDFName('DeviceGray');
            $dict->{'Filter'}           = PDFArray(PDFName('FlateDecode'));
            $dict->{'BitsPerComponent'} = PDFNum($bpc);
            $self->{'SMask'}            = $dict;
        }
        my $scanline = 1 + ceil($bpc * 2 * $w / 8);
        my $bpp = ceil($bpc * 2 / 8);
        my $clearstream = unprocess($bpc, $bpp, 2, $w, $h, $scanline, \$self->{' stream'}, $file);
        delete $self->{' nofilt'};
        delete $self->{' stream'};
        foreach my $n (0 .. ($h * $w) - 1) {
            vec($self->{' stream'}, $n, $bpc) = vec($clearstream, $n * 2,     $bpc);
            vec($dict->{' stream'}, $n, $bpc) = vec($clearstream, $n * 2 + 1, $bpc);
        }
    }

    # RGB + Alpha
    elsif ($cs == 6) {
        $self->filters('FlateDecode');
        $self->colorspace('DeviceRGB');
        $self->bpc($bpc);
        my $dict = PDFDict();
        $self->{'DecodeParms'} = PDFArray($dict);
        $dict->{'BitsPerComponent'} = PDFNum($bpc);
        $dict->{'Colors'} = PDFNum(3);
        $dict->{'Columns'} = PDFNum($w);

        # The unprocess call below removes the PNG optimizations, so use the
        # default Predictor (none) instead of PNG optimized (15), as in other
        # color types.
        #
        # $dict->{'Predictor'} = PDFNum(15);

        $dict = PDFDict();
        unless ($opts{'-notrans'}) {
            $pdf->new_obj($dict);
            $dict->{'Type'}             = PDFName('XObject');
            $dict->{'Subtype'}          = PDFName('Image');
            $dict->{'Width'}            = PDFNum($w);
            $dict->{'Height'}           = PDFNum($h);
            $dict->{'ColorSpace'}       = PDFName('DeviceGray');
            $dict->{'Filter'}           = PDFArray(PDFName('FlateDecode'));
            $dict->{'BitsPerComponent'} = PDFNum($bpc);
            $self->{'SMask'}            = $dict;
        }
        my $scanline = 1 + ceil($bpc * 4 * $w / 8);
        my $bpp = ceil($bpc * 4 / 8);
        my $clearstream = unprocess($bpc, $bpp, 4, $w, $h, $scanline, \$self->{' stream'}, $file);
        delete $self->{' nofilt'};
        delete $self->{' stream'};

        # If possible, use XS to split the Alpha channel from the RGB channels,
        # which is much faster than doing so in Perl.
        if ($use_xs and $bpc == 8 and not $ENV{'PDFAPI2_PNG_PP'}) {
            # Convert the stream to an array before passing it to XS.
            # Otherwise, a 0 byte in the stream would terminate the string.
            my @stream = split '', $clearstream;
            my @outstream_array = @{split_channels(\@stream, $w, $h)};
            $self->{' stream'} = pack("C*", splice @outstream_array, 0, ($w * $h * 3));
            $dict->{' stream'} = pack("C*", splice @outstream_array, 0, ($w * $h));
        }
        else {
            foreach my $n (0 .. ($h * $w) - 1) {
                vec($self->{' stream'}, $n * 3,     $bpc) = vec($clearstream, ($n * 4),     $bpc);
                vec($self->{' stream'}, $n * 3 + 1, $bpc) = vec($clearstream, ($n * 4) + 1, $bpc);
                vec($self->{' stream'}, $n * 3 + 2, $bpc) = vec($clearstream, ($n * 4) + 2, $bpc);
                vec($dict->{' stream'}, $n,         $bpc) = vec($clearstream, ($n * 4) + 3, $bpc);
            }
        }
    }

    # Unknown/Unsupported
    else {
        die "Unknown PNG color type: $cs.";
    }

    return $self;
}

sub PaethPredictor {
    my ($a, $b, $c) = @_;
    my $p = $a + $b - $c;
    my $pa = abs($p - $a);
    my $pb = abs($p - $b);
    my $pc = abs($p - $c);
    if (($pa <= $pb) && ($pa <= $pc)) {
        return $a;
    }
    elsif ($pb <= $pc) {
        return $b;
    }
    else {
        return $c;
    }
}

sub unprocess {
    my ($bpc, $bpp, $comp, $width, $height, $scanline, $sstream, $file) = @_;

    # If Image::PNG::Libpng is available, use it to uncompress and unfilter the
    # image data much more quickly.
    if ($file and not $ENV{'PDFAPI2_PNG_PP'}) {
        eval 'require Image::PNG::Libpng';
        unless ($@) {
            my $libpng;
            eval {
                $libpng = Image::PNG::Libpng::read_png_file($file);
            };
            return join('', @{$libpng->get_rows()}) if $libpng;
        }
    }

    my $stream = uncompress($$sstream);
    my $prev = '';
    my $clearstream = '';

    # The XS code uses a uint8 array so can only handle bpc = 8
    if ($use_xs and $bpc == 8 and not $ENV{'PDFAPI2_PNG_PP'}) {
        my $clearstream_array = [];
        foreach my $n (0 .. $height - 1) {
            my $line = substr($stream, $n * $scanline, $scanline);
            my $filter = vec($line, 0, 8);
            $line = substr($line, 1);

            my @in_line = split '', $line;
            my @prev_line = split '', $prev;
            my $clear_array = unfilter(\@in_line, \@prev_line, $filter, $bpp);
            $prev = pack("C*", @{$clear_array});
            foreach my $x (0 .. ($width * $comp) - 1) {
                $clearstream_array->[($n * $width * $comp) + $x] = $clear_array->[$x];
            }
            no warnings 'uninitialized'; # ignore undefined array elements
            $clearstream = pack("C*", @{$clearstream_array});
        }
    }
    else {
        foreach my $n (0 .. $height - 1) {
            my $line = substr($stream, $n * $scanline, $scanline);
            my $filter = vec($line, 0, 8);
            my $clear = '';
            $line = substr($line, 1);

            # See "Filter Algorithms" in the documentation below for definitions.
            if ($filter == 0) {
                $clear = $line;
            }
            elsif ($filter == 1) {
                foreach my $x (0 .. length($line) - 1) {
                    vec($clear, $x, 8) = (vec($line, $x, 8) + vec($clear, $x - $bpp, 8)) % 256;
                }
            }
            elsif ($filter == 2) {
                foreach my $x (0 .. length($line) - 1) {
                    vec($clear, $x, 8) = (vec($line, $x, 8) + vec($prev, $x, 8)) % 256;
                }
            }
            elsif ($filter == 3) {
                foreach my $x (0 .. length($line) - 1) {
                    vec($clear, $x, 8) = (vec($line, $x, 8) + floor((vec($clear, $x - $bpp, 8) + vec($prev, $x, 8)) / 2)) % 256;
                }
            }
            elsif ($filter == 4) {
                foreach my $x (0 .. length($line) - 1) {
                    vec($clear,$x,8) = (vec($line, $x, 8) + PaethPredictor(vec($clear, $x - $bpp, 8), vec($prev, $x, 8), vec($prev, $x - $bpp, 8))) % 256;
                }
            }

            $prev = $clear;
            foreach my $x (0 .. ($width * $comp) - 1) {
                vec($clearstream, ($n * $width * $comp) + $x, $bpc) = vec($clear, $x, $bpc);
            }
        }
    }
    return $clearstream;
}

1;

__END__