File Coverage

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

Criterion	Covered	Total	%
statement	150	254	59.0
branch	44	78	56.4
condition	9	27	33.3
subroutine	13	13	100.0
pod	2	4	50.0
total	218	376	57.9

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

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

use strict;
use warnings;

our $VERSION = '3.024'; # VERSION
our $LAST_UPDATE = '3.024'; # manually update whenever code is changed

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

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

=head1 NAME

PDF::Builder::Resource::XObject::Image::PNG - support routines for PNG image
library (using pure Perl code).
Inherits from L

=head1 METHODS

=over

=item $res = PDF::Builder::Resource::XObject::Image::PNG->new($pdf, $file, %opts)

Returns a PNG-image object. C<$pdf> is the PDF object being added to, C<$file>
is the input PNG file, and the optional C<$name> of the new parent image object
defaults to PxAAA.

If the Image::PNG::Libpng package is installed, the PNG_IPL library will be
used instead of the PNG library. In such a case, use of the PNG library may be
forced via the C flag (see Builder documentation for C).

B

=over

=item 'notrans' => 1

No transparency -- ignore tRNS chunk if provided, ignore Alpha channel
if provided.

=item 'name' => 'string'

This is the name you can give for the PNG image object. The default is Pxnnnn.

=back

=back

=head2 Supported PNG types

   (0) Gray scale of depth 1, 2, 4, or 8 bits per pixel (2, 4, 16, or 256
       gray levels). 16 bpp is not currently supported (a PNG with 16 bpp
       is a fatal error). Full transparency (of one 8-bit gray value) via
       the tRNS chunk is allowed, unless the notrans option specifies
       that it be ignored.

   (2) RGB 24-bit truecolor with 8 bits per sample (16.7 million colors).
       16 bps is not currently supported (a PNG with 16 bps is a fatal
       error). Full transparency (of one 3x8-bit RGB color value) via the
       tRNS chunk is allowed, unless the notrans option specifies that it
       be ignored.

   (3) Palette color with 1, 2, 4, or 8 bits per pixel (2, 4, 16, or 256
       color table/palette entries). 16 bpp is not currently supported by
       PNG or PDF. Partial transparency (8-bit Alpha) for each palette
       entry via the tRNS chunk is allowed, unless the notrans option
       specifies that it be ignored (all entries fully opaque).

   (4) Gray scale of depth 8 bits per pixel plus 8-bit Alpha channel (256
       gray levels and 256 levels of transparency). 16 bpp is not
       currently supported (a PNG with 16 bpp is a fatal error). The Alpha
       channel is ignored if the notrans option is given. The tRNS chunk
       is not permitted.

   (6) RGB 24-bit truecolor with 8 bits per sample (16.7 million colors)
       plus 8-bit Alpha channel (256 levels of transparency). 16 bps is not
       currently supported (a PNG with 16 bps is a fatal error). The Alpha
       channel is ignored if the notrans option is given. The tRNS chunk
       is not permitted.

In all cases, 16 bits per sample are not implemented. A fatal error will be
returned if a PNG image with 16-bps data is supplied. The code is assuming
standard "network" bit ordering (Big Endian). Interlaced (progressive) display
images are not supported. Use the PNG_IPL version if you need to support 16 bps
or interlaced images.

The transparency chunk (tRNS) will specify one gray level entry or one RGB
entry to be treated as transparent (Alpha = 0). For palette color, up to
256 palette entry 8-bit Alpha values are specified (256 levels of transparency,
from 0 = transparent to 255 = opaque).

Only a limited number of chunks are handled: IHDR, IDAT (internally), PLTE,
tRNS, and IEND (internally). All other chunks are ignored at this time. Certain
filters and compressions applied to data will be handled, but there may be
unsupported methods.

=cut

# TBD: gAMA (gamma) chunk, perhaps some others?

sub new {
    my ($class, $pdf, $file, %opts) = @_;
    # copy dashed option names to preferred undashed names
    if (defined $opts{'-nouseIPL'} && !defined $opts{'nouseIPL'}) { $opts{'nouseIPL'} = delete($opts{'-nouseIPL'}); }
    if (defined $opts{'-notrans'} && !defined $opts{'notrans'}) { $opts{'notrans'} = delete($opts{'-notrans'}); }
    if (defined $opts{'-name'} && !defined $opts{'name'}) { $opts{'name'} = delete($opts{'-name'}); }
    if (defined $opts{'-compress'} && !defined $opts{'compress'}) { $opts{'compress'} = delete($opts{'-compress'}); }

    my ($name, $compress);
    if (exists $opts{'name'}) { $name = $opts{'name'}; }
   #if (exists $opts{'compress'}) { $compress = $opts{'compress'}; }

    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);

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

    if      ($cs == 0){     # greyscale (1,2,4,8 bps, 16 not supported here)
	                    # transparency via tRNS chunk allowed
        # scanline = ceil(bpc * comp / 8)+1
        if ($bpc > 8) {
            die ">8 bits of greylevel in PNG is not supported.";
        } else {
            $self->filters('FlateDecode');
            $self->colorspace('DeviceGray');
            $self->bits_per_component($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 && !$opts{'notrans'}) {
                my $m = mMax(unpack('n*', $trns));
                my $n = mMin(unpack('n*', $trns));
                $self->{'Mask'} = PDFArray(PDFNum($n), PDFNum($m));
            }
        }
    } elsif ($cs == 2) {  # RGB 8 bps (16 not supported here)
	                  # transparency via tRNS chunk allowed
        if ($bpc > 8) {
            die ">8 bits of RGB in PNG is not supported.";
        } else {
            $self->filters('FlateDecode');
            $self->colorspace('DeviceRGB');
            $self->bits_per_component($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 && !$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);
            }
        }
    } elsif ($cs == 3) {  # palette 1,2,4,8 bpp depth (is 16 legal?)
	                  # transparency via tRNS chunk allowed
        if ($bpc > 8) {
            die ">8 bits of palette in PNG is not supported.";
        } else {
            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->bits_per_component($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 && !$opts{'notrans'}) {
                $trns .= "\xFF" x 256; # pad out with opaque entries to
		                       # ensure at least 256 entries available
                $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->{'Filter'} = PDFArray(PDFName('ASCIIHexDecode'));
                $dict->{'BitsPerComponent'} = PDFNum(8);
                $self->{'SMask'} = $dict;
		# length of row (scanline) in bytes, plus 1
                my $scanline = 1 + ceil($bpc * $w/8);
		# bytes per pixel (always 1)
                my $bpp = ceil($bpc/8);
		# uncompressed and unfiltered image data (stream of 1,2,4, or
		# 8 bit indices into palette)
                my $clearstream = unprocess($bpc, $bpp, 1, $w,$h, $scanline, \$self->{' stream'});
                foreach my $n (0 .. ($h*$w)-1) {
		    # dict->stream initially empty. fill with Alpha value for
		    # each pixel, indexed by pixel value
                    vec($dict->{' stream'}, $n, 8) = # each Alpha 8 bits
		      vec($trns, # the table of Alphas corresponding to palette
			  vec($clearstream, $n, $bpc), #1-8 bit index to palette
			  8); # Alpha is 8 bits
                #    print STDERR vec($trns,vec($clearstream,$n,$bpc),8)."=".vec($clearstream,$n,$bpc).",";
                }
                # print STDERR "\n";
            }
        }
    } elsif ($cs == 4) {        # greyscale+alpha 8 bps (16 not supported here)
	                        # transparency via tRNS chunk NOT allowed
        if ($bpc > 8) {
            die ">8 bits of greylevel+alpha in PNG is not supported.";
        } else {
            $self->filters('FlateDecode');
            $self->colorspace('DeviceGray');
            $self->bits_per_component($bpc);
            my $dict = PDFDict();
            $self->{'DecodeParms'} = PDFArray($dict);
            # $dict->{'Predictor'} = PDFNum(15);
            $dict->{'BitsPerComponent'} = PDFNum($bpc);
            $dict->{'Colors'} = PDFNum(1);
            $dict->{'Columns'} = PDFNum($w);

            $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;
            }
	    # as with cs=3, create SMask of Alpha entry for each pixel. this
	    # time, separating Alpha from grayscale and putting in dict->stream
            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'});
            delete $self->{' nofilt'};
	    #delete $self->{' stream'};
	    $dict->{' stream'} = '';
	    $self->{' stream'} = '';
	    # dict->stream is the outer dict if notrans, and the Alpha data
	    #   moved to it is simply unused
	    # dict->stream is the inner dict (created if !notrans), and the
	    #   Alpha data moved to it becomes the SMask
	    # rebuild self->stream from the gray data in clearstream
            foreach my $n (0 .. $h*$w-1) {
                vec($dict->{' stream'}, $n, $bpc) = vec($clearstream, $n*2+1, $bpc);
                vec($self->{' stream'}, $n, $bpc) = vec($clearstream, $n*2, $bpc);
            }
        }
    } elsif ($cs == 6) {  # RGB+alpha 8 bps (16 not supported here)
	                  # transparency via tRNS chunk NOT allowed
        if ($bpc > 8) {
            die ">8 bits of RGB+alpha in PNG is not supported.";
        } else {
            $self->filters('FlateDecode');
            $self->colorspace('DeviceRGB');
            $self->bits_per_component($bpc);
            my $dict = PDFDict();
            $self->{'DecodeParms'} = PDFArray($dict);
            # $dict->{'Predictor'} = PDFNum(15);
            $dict->{'BitsPerComponent'} = PDFNum($bpc);
            $dict->{'Colors'} = PDFNum(3);
            $dict->{'Columns'} = PDFNum($w);

            $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;
            }
	    # bytes per pixel (4 samples) and length of row scanline in bytes
            my $scanline = 1 + ceil($bpc*4 * $w/8);
            my $bpp = ceil($bpc*4 /8);
	    # unpacked, uncompressed, unfiltered image data
            my $clearstream = unprocess($bpc, $bpp, 4, $w,$h, $scanline, \$self->{' stream'});
            delete $self->{' nofilt'};
	    #delete $self->{' stream'};
	    $dict->{' stream'} = '';
	    $self->{' stream'} = '';
	    # as with cs=4, create SMask of Alpha entry for each pixel. this
	    # time, separating Alpha from RGB triplet and put in dict->stream
	    # dict->stream is the outer dict if notrans, and the Alpha data
	    #   moved to it is simply unused
	    # dict->stream is the inner dict (created if !notrans), and the
	    #   Alpha data moved to it becomes the SMask
	    # rebuild self->stream from the RGB data in clearstream 1/3 smaller
            foreach my $n (0 .. ($h*$w)-1) {
	       # pull out Alpha data bpc bits into new dict SMask
                vec($dict->{' stream'}, $n, $bpc) = vec($clearstream, $n*4+3, $bpc);
	       # transfer RGB triplet into self->stream
                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);
            }
        }
    } else {
        die "unsupported PNG-color type (cs=$cs).";
    }

    return($self);
}

=over

=item  $mode = $png->usesLib()

Returns 1 if Image::PNG::Libpng installed and used, 0 if not installed, or -1
if installed but not used (nouseIPL option given to C).

B this method can only be used I the image object has been
created. It can't tell you whether Image::PNG::Libpng is available in
advance of actually using it, in case you want to use some functionality
available only in PNG_IPL. See the L LA_IPL() call if you
need to know in advance.

=back

=cut

sub usesLib {
    my ($self) = shift;
    # should be 0 for Image::PNG::Libpng not installed, or -1 for is installed,
    # but not using it
    return $self->{'usesIPL'}->val();
}

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) = @_;

    my $stream = uncompress($$sstream);
    my $prev = '';
    my $clearstream = '';
    foreach my $n (0 .. $height-1) {
        # print STDERR "line $n:";
        my $line = substr($stream, $n*$scanline, $scanline);
        my $filter = vec($line, 0, 8);
        my $clear = '';
        $line = substr($line, 1);
        # print STDERR " filter=$filter";
        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);
        #    print STDERR "".vec($clear,$x,$bpc).",";
        }
        # print STDERR "\n";
    }
    return $clearstream;
}

1;

__END__