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


line stmt bran cond sub pod time code
1             package PDF::API2::Resource::XObject::Image::PNG;
2              
3 2     2   1124 use base 'PDF::API2::Resource::XObject::Image';
  2         4  
  2         586  
4              
5 2     2   16 use strict;
  2         5  
  2         42  
6 2     2   10 use warnings;
  2         4  
  2         78  
7              
8             our $VERSION = '2.044'; # VERSION
9              
10 2     2   11 use Compress::Zlib;
  2         4  
  2         639  
11 2     2   15 use POSIX qw(ceil floor);
  2         7  
  2         19  
12              
13 2     2   181 use IO::File;
  2         4  
  2         336  
14 2     2   14 use PDF::API2::Util;
  2         5  
  2         269  
15 2     2   14 use PDF::API2::Basic::PDF::Utils;
  2         3  
  2         176  
16 2     2   12 use Scalar::Util qw(weaken);
  2         5  
  2         4876  
17              
18 2     2   357 eval 'use PDF::API2::XS::ImagePNG';
  0         0  
  0         0  
19             my $use_xs = $@ ? 0 : 1;
20              
21             sub new {
22 5     5 1 19 my ($class, $pdf, $file, $name, %opts) = @_;
23 5         8 my $self;
24              
25 5 50       16 $class = ref($class) if ref($class);
26              
27 5   33     30 $self = $class->SUPER::new($pdf, $name || 'Px' . pdfkey());
28 5 50       15 $pdf->new_obj($self) unless $self->is_obj($pdf);
29              
30 5         13 $self->{' apipdf'} = $pdf;
31 5         15 weaken $self->{' apipdf'};
32              
33 5         29 my $fh = IO::File->new();
34 5 100       185 if (ref($file)) {
35 1         4 $fh = $file;
36             }
37             else {
38 4 100       244 open $fh, '<', $file or die "$!: $file";
39             }
40 4         28 binmode $fh, ':raw';
41              
42 4         13 my ($buf, $l, $crc, $w, $h, $bpc, $cs, $cm, $fm, $im, $palette, $trns);
43 4         34 seek($fh, 8, 0);
44 4         18 $self->{' stream'} = '';
45 4         15 $self->{' nofilt'} = 1;
46 4         157 while (!eof($fh)) {
47 18         43 read($fh, $buf, 4);
48 18         58 $l = unpack('N', $buf);
49 18         36 read($fh, $buf, 4);
50 18 100       72 if ($buf eq 'IHDR') {
    100          
    100          
    50          
    100          
51 4         9 read($fh, $buf, $l);
52 4         18 ($w, $h, $bpc, $cs, $cm, $fm, $im) = unpack('NNCCCCC', $buf);
53 4 50       11 die "Unsupported Compression($cm) Method" if $cm;
54 4 50       10 die "Unsupported Interlace($im) Method" if $im;
55 4 50       11 die "Unsupported Filter($fm) Method" if $fm;
56             }
57             elsif ($buf eq 'PLTE') {
58 2         3 read($fh, $buf, $l);
59 2         5 $palette = $buf;
60             }
61             elsif ($buf eq 'IDAT') {
62 4         85 read($fh, $buf, $l);
63 4         48 $self->{' stream'} .= $buf;
64             }
65             elsif ($buf eq 'tRNS') {
66 0         0 read($fh, $buf, $l);
67 0         0 $trns = $buf;
68             }
69             elsif ($buf eq 'IEND') {
70 4         9 last;
71             }
72             else {
73             # skip ahead
74 4         44 seek($fh, $l, 1);
75             }
76 14         55 read($fh, $buf, 4);
77 14         40 $crc = $buf;
78             }
79 4 100       68 close $fh unless ref($file);
80              
81 4         30 $self->width($w);
82 4         19 $self->height($h);
83              
84             # BPC = bits per component, and may be 1, 2, 4, 8, or 16 per the PNG spec.
85             # Color types may further restrict the available options. Additionally,
86             # this module doesn't currently support 16-bit components.
87 4 50       10 if ($bpc == 16) {
88 0         0 die '16-bit colors/transparency are not supported.';
89             }
90 4 50 66     31 unless ($bpc == 1 or $bpc == 2 or $bpc == 4 or $bpc == 8) {
      66        
      33        
91 0         0 die "Invalid component bit depth: $bpc.";
92             }
93              
94             # Grayscale
95 4 50       22 if ($cs == 0) {
    50          
    100          
    50          
    50          
96 0         0 $self->filters('FlateDecode');
97 0         0 $self->colorspace('DeviceGray');
98 0         0 $self->bpc($bpc);
99 0         0 my $dict = PDFDict();
100 0         0 $self->{'DecodeParms'} = PDFArray($dict);
101 0         0 $dict->{'Predictor'} = PDFNum(15);
102 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
103 0         0 $dict->{'Colors'} = PDFNum(1);
104 0         0 $dict->{'Columns'} = PDFNum($w);
105 0 0 0     0 if (defined $trns and not $opts{'-notrans'}) {
106 0         0 my $m = mMax(unpack('n*', $trns));
107 0         0 my $n = mMin(unpack('n*', $trns));
108 0         0 $self->{'Mask'} = PDFArray(PDFNum($n), PDFNum($m));
109             }
110             }
111              
112             # RGB
113             elsif ($cs == 2) {
114 0         0 $self->filters('FlateDecode');
115 0         0 $self->colorspace('DeviceRGB');
116 0         0 $self->bpc($bpc);
117 0         0 my $dict = PDFDict();
118 0         0 $self->{'DecodeParms'} = PDFArray($dict);
119 0         0 $dict->{'Predictor'} = PDFNum(15);
120 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
121 0         0 $dict->{'Colors'} = PDFNum(3);
122 0         0 $dict->{'Columns'} = PDFNum($w);
123 0 0 0     0 if (defined $trns and not $opts{'-notrans'}) {
124 0         0 my @v = unpack('n*', $trns);
125 0         0 my (@cr, @cg, @cb, $m, $n);
126 0         0 while (scalar @v > 0) {
127 0         0 push @cr, shift(@v);
128 0         0 push @cg, shift(@v);
129 0         0 push @cb, shift(@v);
130             }
131 0         0 @v = ();
132 0         0 $m = mMax(@cr);
133 0         0 $n = mMin(@cr);
134 0         0 push @v, $n, $m;
135 0         0 $m = mMax(@cg);
136 0         0 $n = mMin(@cg);
137 0         0 push @v, $n, $m;
138 0         0 $m = mMax(@cb);
139 0         0 $n = mMin(@cb);
140 0         0 push @v, $n, $m;
141 0         0 $self->{'Mask'} = PDFArray(map { PDFNum($_) } @v);
  0         0  
142             }
143             }
144              
145             # Palette Index
146             elsif ($cs == 3) {
147 2         5 my $dict = PDFDict();
148 2         9 $pdf->new_obj($dict);
149 2         6 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
150 2         5 $dict->{' stream'} = $palette;
151 2         4 $palette = '';
152 2         13 $self->filters('FlateDecode');
153 2         5 $self->colorspace(PDFArray(PDFName('Indexed'), PDFName('DeviceRGB'), PDFNum(int(length($dict->{' stream'}) / 3) - 1), $dict));
154 2         9 $self->bpc($bpc);
155 2         5 $dict = PDFDict();
156 2         5 $self->{'DecodeParms'} = PDFArray($dict);
157 2         6 $dict->{'Predictor'} = PDFNum(15);
158 2         5 $dict->{'BitsPerComponent'} = PDFNum($bpc);
159 2         4 $dict->{'Colors'} = PDFNum(1);
160 2         11 $dict->{'Columns'} = PDFNum($w);
161 2 50 33     8 if (defined $trns and not $opts{'-notrans'}) {
162 0         0 $trns .= "\xFF" x 256;
163 0         0 $dict = PDFDict();
164 0         0 $pdf->new_obj($dict);
165 0         0 $dict->{'Type'} = PDFName('XObject');
166 0         0 $dict->{'Subtype'} = PDFName('Image');
167 0         0 $dict->{'Width'} = PDFNum($w);
168 0         0 $dict->{'Height'} = PDFNum($h);
169 0         0 $dict->{'ColorSpace'} = PDFName('DeviceGray');
170 0         0 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
171 0         0 $dict->{'BitsPerComponent'} = PDFNum(8);
172 0         0 $self->{'SMask'} = $dict;
173 0         0 my $scanline = 1 + ceil($bpc * $w / 8);
174 0         0 my $bpp = ceil($bpc / 8);
175 0         0 my $clearstream = unprocess($bpc, $bpp, 1, $w, $h, $scanline, \$self->{' stream'}, $file);
176 0         0 foreach my $n (0 .. ($h * $w) - 1) {
177 0         0 vec($dict->{' stream'}, $n, 8) = vec($trns, vec($clearstream, $n, $bpc), 8);
178             }
179             }
180             }
181              
182             # Grayscale + Alpha
183             elsif ($cs == 4) {
184 0         0 $self->filters('FlateDecode');
185 0         0 $self->colorspace('DeviceGray');
186 0         0 $self->bpc($bpc);
187 0         0 my $dict = PDFDict();
188 0         0 $self->{'DecodeParms'} = PDFArray($dict);
189 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
190 0         0 $dict->{'Colors'} = PDFNum(1);
191 0         0 $dict->{'Columns'} = PDFNum($w);
192              
193             # The unprocess call below removes the PNG optimizations, so use the
194             # default Predictor (none) instead of PNG optimized (15), as in other
195             # color types.
196             #
197             # $dict->{'Predictor'} = PDFNum(15);
198              
199 0         0 $dict = PDFDict();
200 0 0       0 unless ($opts{'-notrans'}) {
201 0         0 $pdf->new_obj($dict);
202 0         0 $dict->{'Type'} = PDFName('XObject');
203 0         0 $dict->{'Subtype'} = PDFName('Image');
204 0         0 $dict->{'Width'} = PDFNum($w);
205 0         0 $dict->{'Height'} = PDFNum($h);
206 0         0 $dict->{'ColorSpace'} = PDFName('DeviceGray');
207 0         0 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
208 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
209 0         0 $self->{'SMask'} = $dict;
210             }
211 0         0 my $scanline = 1 + ceil($bpc * 2 * $w / 8);
212 0         0 my $bpp = ceil($bpc * 2 / 8);
213 0         0 my $clearstream = unprocess($bpc, $bpp, 2, $w, $h, $scanline, \$self->{' stream'}, $file);
214 0         0 delete $self->{' nofilt'};
215 0         0 delete $self->{' stream'};
216 0         0 foreach my $n (0 .. ($h * $w) - 1) {
217 0         0 vec($self->{' stream'}, $n, $bpc) = vec($clearstream, $n * 2, $bpc);
218 0         0 vec($dict->{' stream'}, $n, $bpc) = vec($clearstream, $n * 2 + 1, $bpc);
219             }
220             }
221              
222             # RGB + Alpha
223             elsif ($cs == 6) {
224 2         10 $self->filters('FlateDecode');
225 2         11 $self->colorspace('DeviceRGB');
226 2         9 $self->bpc($bpc);
227 2         6 my $dict = PDFDict();
228 2         13 $self->{'DecodeParms'} = PDFArray($dict);
229 2         9 $dict->{'BitsPerComponent'} = PDFNum($bpc);
230 2         6 $dict->{'Colors'} = PDFNum(3);
231 2         8 $dict->{'Columns'} = PDFNum($w);
232              
233             # The unprocess call below removes the PNG optimizations, so use the
234             # default Predictor (none) instead of PNG optimized (15), as in other
235             # color types.
236             #
237             # $dict->{'Predictor'} = PDFNum(15);
238              
239 2         5 $dict = PDFDict();
240 2 50       9 unless ($opts{'-notrans'}) {
241 2         8 $pdf->new_obj($dict);
242 2         6 $dict->{'Type'} = PDFName('XObject');
243 2         7 $dict->{'Subtype'} = PDFName('Image');
244 2         7 $dict->{'Width'} = PDFNum($w);
245 2         6 $dict->{'Height'} = PDFNum($h);
246 2         6 $dict->{'ColorSpace'} = PDFName('DeviceGray');
247 2         6 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
248 2         5 $dict->{'BitsPerComponent'} = PDFNum($bpc);
249 2         6 $self->{'SMask'} = $dict;
250             }
251 2         16 my $scanline = 1 + ceil($bpc * 4 * $w / 8);
252 2         8 my $bpp = ceil($bpc * 4 / 8);
253 2         10 my $clearstream = unprocess($bpc, $bpp, 4, $w, $h, $scanline, \$self->{' stream'}, $file);
254 2         21 delete $self->{' nofilt'};
255 2         16 delete $self->{' stream'};
256              
257             # If possible, use XS to split the Alpha channel from the RGB channels,
258             # which is much faster than doing so in Perl.
259 2 50 33     47 if ($use_xs and $bpc == 8 and not $ENV{'PDFAPI2_PNG_PP'}) {
      33        
260             # Convert the stream to an array before passing it to XS.
261             # Otherwise, a 0 byte in the stream would terminate the string.
262 0         0 my @stream = split '', $clearstream;
263 0         0 my @outstream_array = @{split_channels(\@stream, $w, $h)};
  0         0  
264 0         0 $self->{' stream'} = pack("C*", splice @outstream_array, 0, ($w * $h * 3));
265 0         0 $dict->{' stream'} = pack("C*", splice @outstream_array, 0, ($w * $h));
266             }
267             else {
268 2         15 foreach my $n (0 .. ($h * $w) - 1) {
269 218120         398526 vec($self->{' stream'}, $n * 3, $bpc) = vec($clearstream, ($n * 4), $bpc);
270 218120         417760 vec($self->{' stream'}, $n * 3 + 1, $bpc) = vec($clearstream, ($n * 4) + 1, $bpc);
271 218120         417216 vec($self->{' stream'}, $n * 3 + 2, $bpc) = vec($clearstream, ($n * 4) + 2, $bpc);
272 218120         471608 vec($dict->{' stream'}, $n, $bpc) = vec($clearstream, ($n * 4) + 3, $bpc);
273             }
274             }
275             }
276              
277             # Unknown/Unsupported
278             else {
279 0         0 die "Unknown PNG color type: $cs.";
280             }
281              
282 4         50 return $self;
283             }
284              
285             sub PaethPredictor {
286 94240     94240 0 193560 my ($a, $b, $c) = @_;
287 94240         140794 my $p = $a + $b - $c;
288 94240         127890 my $pa = abs($p - $a);
289 94240         127452 my $pb = abs($p - $b);
290 94240         128761 my $pc = abs($p - $c);
291 94240 100 100     233895 if (($pa <= $pb) && ($pa <= $pc)) {
    100          
292 82304         245029 return $a;
293             }
294             elsif ($pb <= $pc) {
295 11154         32207 return $b;
296             }
297             else {
298 782         2332 return $c;
299             }
300             }
301              
302             sub unprocess {
303 2     2 0 7 my ($bpc, $bpp, $comp, $width, $height, $scanline, $sstream, $file) = @_;
304              
305             # If Image::PNG::Libpng is available, use it to uncompress and unfilter the
306             # image data much more quickly.
307 2 100 66     13 if ($file and not $ENV{'PDFAPI2_PNG_PP'}) {
308 1         76 eval 'require Image::PNG::Libpng';
309 1 50       8 unless ($@) {
310 0         0 my $libpng;
311 0         0 eval {
312 0         0 $libpng = Image::PNG::Libpng::read_png_file($file);
313             };
314 0 0       0 return join('', @{$libpng->get_rows()}) if $libpng;
  0         0  
315             }
316             }
317              
318 2         10 my $stream = uncompress($$sstream);
319 2         5249 my $prev = '';
320 2         5 my $clearstream = '';
321              
322             # The XS code uses a uint8 array so can only handle bpc = 8
323 2 50 33     14 if ($use_xs and $bpc == 8 and not $ENV{'PDFAPI2_PNG_PP'}) {
      33        
324 0         0 my $clearstream_array = [];
325 0         0 foreach my $n (0 .. $height - 1) {
326 0         0 my $line = substr($stream, $n * $scanline, $scanline);
327 0         0 my $filter = vec($line, 0, 8);
328 0         0 $line = substr($line, 1);
329              
330 0         0 my @in_line = split '', $line;
331 0         0 my @prev_line = split '', $prev;
332 0         0 my $clear_array = unfilter(\@in_line, \@prev_line, $filter, $bpp);
333 0         0 $prev = pack("C*", @{$clear_array});
  0         0  
334 0         0 foreach my $x (0 .. ($width * $comp) - 1) {
335 0         0 $clearstream_array->[($n * $width * $comp) + $x] = $clear_array->[$x];
336             }
337 2     2   19 no warnings 'uninitialized'; # ignore undefined array elements
  2         4  
  2         821  
338 0         0 $clearstream = pack("C*", @{$clearstream_array});
  0         0  
339             }
340             }
341             else {
342 2         100 foreach my $n (0 .. $height - 1) {
343 574         2373 my $line = substr($stream, $n * $scanline, $scanline);
344 574         884 my $filter = vec($line, 0, 8);
345 574         785 my $clear = '';
346 574         1257 $line = substr($line, 1);
347              
348             # See "Filter Algorithms" in the documentation below for definitions.
349 574 50       1631 if ($filter == 0) {
    100          
    100          
    50          
    50          
350 0         0 $clear = $line;
351             }
352             elsif ($filter == 1) {
353 18         49 foreach my $x (0 .. length($line) - 1) {
354 27360         56534 vec($clear, $x, 8) = (vec($line, $x, 8) + vec($clear, $x - $bpp, 8)) % 256;
355             }
356             }
357             elsif ($filter == 2) {
358 494         1096 foreach my $x (0 .. length($line) - 1) {
359 750880         1526882 vec($clear, $x, 8) = (vec($line, $x, 8) + vec($prev, $x, 8)) % 256;
360             }
361             }
362             elsif ($filter == 3) {
363 0         0 foreach my $x (0 .. length($line) - 1) {
364 0         0 vec($clear, $x, 8) = (vec($line, $x, 8) + floor((vec($clear, $x - $bpp, 8) + vec($prev, $x, 8)) / 2)) % 256;
365             }
366             }
367             elsif ($filter == 4) {
368 62         166 foreach my $x (0 .. length($line) - 1) {
369 94240         226458 vec($clear,$x,8) = (vec($line, $x, 8) + PaethPredictor(vec($clear, $x - $bpp, 8), vec($prev, $x, 8), vec($prev, $x - $bpp, 8))) % 256;
370             }
371             }
372              
373 574         1164 $prev = $clear;
374 574         1329 foreach my $x (0 .. ($width * $comp) - 1) {
375 872480         1725984 vec($clearstream, ($n * $width * $comp) + $x, $bpc) = vec($clear, $x, $bpc);
376             }
377             }
378             }
379 2         1125 return $clearstream;
380             }
381              
382             1;
383              
384             __END__