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


line stmt bran cond sub pod time code
1             package PDF::Builder::Resource::XObject::Image::PNG;
2              
3 2     2   1209 use base 'PDF::Builder::Resource::XObject::Image';
  2         4  
  2         489  
4              
5 2     2   13 use strict;
  2         5  
  2         33  
6 2     2   9 use warnings;
  2         4  
  2         79  
7              
8             our $VERSION = '3.024'; # VERSION
9             our $LAST_UPDATE = '3.024'; # manually update whenever code is changed
10              
11 2     2   11 use Compress::Zlib;
  2         4  
  2         525  
12 2     2   13 use POSIX qw(ceil floor);
  2         4  
  2         14  
13              
14 2     2   167 use IO::File;
  2         4  
  2         274  
15 2     2   14 use PDF::Builder::Util;
  2         3  
  2         270  
16 2     2   13 use PDF::Builder::Basic::PDF::Utils;
  2         4  
  2         121  
17 2     2   11 use Scalar::Util qw(weaken);
  2         3  
  2         4235  
18              
19             =head1 NAME
20              
21             PDF::Builder::Resource::XObject::Image::PNG - support routines for PNG image
22             library (using pure Perl code).
23             Inherits from L
24              
25             =head1 METHODS
26              
27             =over
28              
29             =item $res = PDF::Builder::Resource::XObject::Image::PNG->new($pdf, $file, %opts)
30              
31             Returns a PNG-image object. C<$pdf> is the PDF object being added to, C<$file>
32             is the input PNG file, and the optional C<$name> of the new parent image object
33             defaults to PxAAA.
34              
35             If the Image::PNG::Libpng package is installed, the PNG_IPL library will be
36             used instead of the PNG library. In such a case, use of the PNG library may be
37             forced via the C flag (see Builder documentation for C).
38              
39             B
40              
41             =over
42              
43             =item 'notrans' => 1
44              
45             No transparency -- ignore tRNS chunk if provided, ignore Alpha channel
46             if provided.
47              
48             =item 'name' => 'string'
49              
50             This is the name you can give for the PNG image object. The default is Pxnnnn.
51              
52             =back
53              
54             =back
55              
56             =head2 Supported PNG types
57              
58             (0) Gray scale of depth 1, 2, 4, or 8 bits per pixel (2, 4, 16, or 256
59             gray levels). 16 bpp is not currently supported (a PNG with 16 bpp
60             is a fatal error). Full transparency (of one 8-bit gray value) via
61             the tRNS chunk is allowed, unless the notrans option specifies
62             that it be ignored.
63              
64             (2) RGB 24-bit truecolor with 8 bits per sample (16.7 million colors).
65             16 bps is not currently supported (a PNG with 16 bps is a fatal
66             error). Full transparency (of one 3x8-bit RGB color value) via the
67             tRNS chunk is allowed, unless the notrans option specifies that it
68             be ignored.
69              
70             (3) Palette color with 1, 2, 4, or 8 bits per pixel (2, 4, 16, or 256
71             color table/palette entries). 16 bpp is not currently supported by
72             PNG or PDF. Partial transparency (8-bit Alpha) for each palette
73             entry via the tRNS chunk is allowed, unless the notrans option
74             specifies that it be ignored (all entries fully opaque).
75              
76             (4) Gray scale of depth 8 bits per pixel plus 8-bit Alpha channel (256
77             gray levels and 256 levels of transparency). 16 bpp is not
78             currently supported (a PNG with 16 bpp is a fatal error). The Alpha
79             channel is ignored if the notrans option is given. The tRNS chunk
80             is not permitted.
81              
82             (6) RGB 24-bit truecolor with 8 bits per sample (16.7 million colors)
83             plus 8-bit Alpha channel (256 levels of transparency). 16 bps is not
84             currently supported (a PNG with 16 bps is a fatal error). The Alpha
85             channel is ignored if the notrans option is given. The tRNS chunk
86             is not permitted.
87              
88             In all cases, 16 bits per sample are not implemented. A fatal error will be
89             returned if a PNG image with 16-bps data is supplied. The code is assuming
90             standard "network" bit ordering (Big Endian). Interlaced (progressive) display
91             images are not supported. Use the PNG_IPL version if you need to support 16 bps
92             or interlaced images.
93              
94             The transparency chunk (tRNS) will specify one gray level entry or one RGB
95             entry to be treated as transparent (Alpha = 0). For palette color, up to
96             256 palette entry 8-bit Alpha values are specified (256 levels of transparency,
97             from 0 = transparent to 255 = opaque).
98              
99             Only a limited number of chunks are handled: IHDR, IDAT (internally), PLTE,
100             tRNS, and IEND (internally). All other chunks are ignored at this time. Certain
101             filters and compressions applied to data will be handled, but there may be
102             unsupported methods.
103              
104             =cut
105              
106             # TBD: gAMA (gamma) chunk, perhaps some others?
107              
108             sub new {
109 5     5 1 19 my ($class, $pdf, $file, %opts) = @_;
110             # copy dashed option names to preferred undashed names
111 5 50 33     20 if (defined $opts{'-nouseIPL'} && !defined $opts{'nouseIPL'}) { $opts{'nouseIPL'} = delete($opts{'-nouseIPL'}); }
  0         0  
112 5 50 33     16 if (defined $opts{'-notrans'} && !defined $opts{'notrans'}) { $opts{'notrans'} = delete($opts{'-notrans'}); }
  0         0  
113 5 50 33     17 if (defined $opts{'-name'} && !defined $opts{'name'}) { $opts{'name'} = delete($opts{'-name'}); }
  0         0  
114 5 50 33     14 if (defined $opts{'-compress'} && !defined $opts{'compress'}) { $opts{'compress'} = delete($opts{'-compress'}); }
  0         0  
115              
116 5         9 my ($name, $compress);
117 5 50       13 if (exists $opts{'name'}) { $name = $opts{'name'}; }
  0         0  
118             #if (exists $opts{'compress'}) { $compress = $opts{'compress'}; }
119              
120 5         7 my $self;
121              
122 5 50       13 $class = ref($class) if ref($class);
123              
124 5   33     24 $self = $class->SUPER::new($pdf, $name || 'Px'.pdfkey());
125 5 50       17 $pdf->new_obj($self) unless $self->is_obj($pdf);
126              
127 5         12 $self->{' apipdf'} = $pdf;
128 5         17 weaken $self->{' apipdf'};
129              
130 5         30 my $fh = IO::File->new();
131 5 100       173 if (ref($file)) {
132 1         3 $fh = $file;
133             } else {
134 4 100       213 open $fh, '<', $file or die "$!: $file";
135             }
136 4         28 binmode($fh, ':raw');
137              
138 4         9 my ($buf, $l, $crc, $w,$h, $bpc, $cs, $cm, $fm, $im, $palette, $trns);
139 4         34 seek($fh, 8, 0);
140 4         18 $self->{' stream'} = '';
141 4         17 $self->{' nofilt'} = 1;
142 4         118 while (!eof($fh)) {
143 18         42 read($fh, $buf, 4);
144 18         33 $l = unpack('N', $buf);
145 18         29 read($fh, $buf, 4);
146 18 100       58 if ($buf eq 'IHDR') {
    100          
    100          
    50          
    100          
147 4         8 read($fh, $buf, $l);
148 4         15 ($w, $h, $bpc, $cs, $cm, $fm, $im) = unpack('NNCCCCC', $buf);
149 4 50       12 die "Unsupported Compression($cm) Method" if $cm;
150 4 50       10 die "Unsupported Interlace($im) Method" if $im;
151 4 50       9 die "Unsupported Filter($fm) Method" if $fm;
152             } elsif ($buf eq 'PLTE') {
153 2         4 read($fh, $buf, $l);
154 2         4 $palette = $buf;
155             } elsif ($buf eq 'IDAT') {
156 4         77 read($fh, $buf, $l);
157 4         45 $self->{' stream'} .= $buf;
158             } elsif ($buf eq 'tRNS') {
159 0         0 read($fh, $buf, $l);
160 0         0 $trns = $buf;
161             } elsif ($buf eq 'IEND') {
162 4         10 last;
163             } else {
164             # skip ahead
165 4         40 seek($fh, $l, 1);
166             }
167 14         51 read($fh, $buf, 4);
168 14         32 $crc = $buf;
169             }
170 4         68 close($fh);
171              
172 4         32 $self->width($w);
173 4         14 $self->height($h);
174              
175 4 50       25 if ($cs == 0){ # greyscale (1,2,4,8 bps, 16 not supported here)
    50          
    100          
    50          
    50          
176             # transparency via tRNS chunk allowed
177             # scanline = ceil(bpc * comp / 8)+1
178 0 0       0 if ($bpc > 8) {
179 0         0 die ">8 bits of greylevel in PNG is not supported.";
180             } else {
181 0         0 $self->filters('FlateDecode');
182 0         0 $self->colorspace('DeviceGray');
183 0         0 $self->bits_per_component($bpc);
184 0         0 my $dict = PDFDict();
185 0         0 $self->{'DecodeParms'} = PDFArray($dict);
186 0         0 $dict->{'Predictor'} = PDFNum(15);
187 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
188 0         0 $dict->{'Colors'} = PDFNum(1);
189 0         0 $dict->{'Columns'} = PDFNum($w);
190 0 0 0     0 if (defined $trns && !$opts{'notrans'}) {
191 0         0 my $m = mMax(unpack('n*', $trns));
192 0         0 my $n = mMin(unpack('n*', $trns));
193 0         0 $self->{'Mask'} = PDFArray(PDFNum($n), PDFNum($m));
194             }
195             }
196             } elsif ($cs == 2) { # RGB 8 bps (16 not supported here)
197             # transparency via tRNS chunk allowed
198 0 0       0 if ($bpc > 8) {
199 0         0 die ">8 bits of RGB in PNG is not supported.";
200             } else {
201 0         0 $self->filters('FlateDecode');
202 0         0 $self->colorspace('DeviceRGB');
203 0         0 $self->bits_per_component($bpc);
204 0         0 my $dict = PDFDict();
205 0         0 $self->{'DecodeParms'} = PDFArray($dict);
206 0         0 $dict->{'Predictor'} = PDFNum(15);
207 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
208 0         0 $dict->{'Colors'} = PDFNum(3);
209 0         0 $dict->{'Columns'} = PDFNum($w);
210 0 0 0     0 if (defined $trns && !$opts{'notrans'}) {
211 0         0 my @v = unpack('n*', $trns);
212 0         0 my (@cr,@cg,@cb, $m, $n);
213 0         0 while (scalar @v > 0) {
214 0         0 push(@cr, shift(@v));
215 0         0 push(@cg, shift(@v));
216 0         0 push(@cb, shift(@v));
217             }
218 0         0 @v = ();
219 0         0 $m = mMax(@cr);
220 0         0 $n = mMin(@cr);
221 0         0 push @v, $n,$m;
222 0         0 $m = mMax(@cg);
223 0         0 $n = mMin(@cg);
224 0         0 push @v, $n,$m;
225 0         0 $m = mMax(@cb);
226 0         0 $n = mMin(@cb);
227 0         0 push @v, $n,$m;
228 0         0 $self->{'Mask'} = PDFArray(map { PDFNum($_) } @v);
  0         0  
229             }
230             }
231             } elsif ($cs == 3) { # palette 1,2,4,8 bpp depth (is 16 legal?)
232             # transparency via tRNS chunk allowed
233 2 50       5 if ($bpc > 8) {
234 0         0 die ">8 bits of palette in PNG is not supported.";
235             } else {
236 2         5 my $dict = PDFDict();
237 2         8 $pdf->new_obj($dict);
238 2         6 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
239 2         4 $dict->{' stream'} = $palette;
240 2         4 $palette = "";
241 2         16 $self->filters('FlateDecode');
242 2         7 $self->colorspace(PDFArray(PDFName('Indexed'), PDFName('DeviceRGB'), PDFNum(int(length($dict->{' stream'})/3)-1), $dict));
243 2         8 $self->bits_per_component($bpc);
244 2         5 $dict = PDFDict();
245 2         5 $self->{'DecodeParms'} = PDFArray($dict);
246 2         16 $dict->{'Predictor'} = PDFNum(15);
247 2         10 $dict->{'BitsPerComponent'} = PDFNum($bpc);
248 2         6 $dict->{'Colors'} = PDFNum(1);
249 2         5 $dict->{'Columns'} = PDFNum($w);
250 2 50 33     7 if (defined $trns && !$opts{'notrans'}) {
251 0         0 $trns .= "\xFF" x 256; # pad out with opaque entries to
252             # ensure at least 256 entries available
253 0         0 $dict = PDFDict();
254 0         0 $pdf->new_obj($dict);
255 0         0 $dict->{'Type'} = PDFName('XObject');
256 0         0 $dict->{'Subtype'} = PDFName('Image');
257 0         0 $dict->{'Width'} = PDFNum($w);
258 0         0 $dict->{'Height'} = PDFNum($h);
259 0         0 $dict->{'ColorSpace'} = PDFName('DeviceGray');
260 0         0 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
261             # $dict->{'Filter'} = PDFArray(PDFName('ASCIIHexDecode'));
262 0         0 $dict->{'BitsPerComponent'} = PDFNum(8);
263 0         0 $self->{'SMask'} = $dict;
264             # length of row (scanline) in bytes, plus 1
265 0         0 my $scanline = 1 + ceil($bpc * $w/8);
266             # bytes per pixel (always 1)
267 0         0 my $bpp = ceil($bpc/8);
268             # uncompressed and unfiltered image data (stream of 1,2,4, or
269             # 8 bit indices into palette)
270 0         0 my $clearstream = unprocess($bpc, $bpp, 1, $w,$h, $scanline, \$self->{' stream'});
271 0         0 foreach my $n (0 .. ($h*$w)-1) {
272             # dict->stream initially empty. fill with Alpha value for
273             # each pixel, indexed by pixel value
274 0         0 vec($dict->{' stream'}, $n, 8) = # each Alpha 8 bits
275             vec($trns, # the table of Alphas corresponding to palette
276             vec($clearstream, $n, $bpc), #1-8 bit index to palette
277             8); # Alpha is 8 bits
278             # print STDERR vec($trns,vec($clearstream,$n,$bpc),8)."=".vec($clearstream,$n,$bpc).",";
279             }
280             # print STDERR "\n";
281             }
282             }
283             } elsif ($cs == 4) { # greyscale+alpha 8 bps (16 not supported here)
284             # transparency via tRNS chunk NOT allowed
285 0 0       0 if ($bpc > 8) {
286 0         0 die ">8 bits of greylevel+alpha in PNG is not supported.";
287             } else {
288 0         0 $self->filters('FlateDecode');
289 0         0 $self->colorspace('DeviceGray');
290 0         0 $self->bits_per_component($bpc);
291 0         0 my $dict = PDFDict();
292 0         0 $self->{'DecodeParms'} = PDFArray($dict);
293             # $dict->{'Predictor'} = PDFNum(15);
294 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
295 0         0 $dict->{'Colors'} = PDFNum(1);
296 0         0 $dict->{'Columns'} = PDFNum($w);
297              
298 0         0 $dict = PDFDict();
299 0 0       0 unless ($opts{'notrans'}) {
300 0         0 $pdf->new_obj($dict);
301 0         0 $dict->{'Type'} = PDFName('XObject');
302 0         0 $dict->{'Subtype'} = PDFName('Image');
303 0         0 $dict->{'Width'} = PDFNum($w);
304 0         0 $dict->{'Height'} = PDFNum($h);
305 0         0 $dict->{'ColorSpace'} = PDFName('DeviceGray');
306 0         0 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
307 0         0 $dict->{'BitsPerComponent'} = PDFNum($bpc);
308 0         0 $self->{'SMask'} = $dict;
309             }
310             # as with cs=3, create SMask of Alpha entry for each pixel. this
311             # time, separating Alpha from grayscale and putting in dict->stream
312 0         0 my $scanline = 1 + ceil($bpc*2 * $w/8);
313 0         0 my $bpp = ceil($bpc*2 / 8);
314 0         0 my $clearstream = unprocess($bpc, $bpp, 2, $w,$h, $scanline, \$self->{' stream'});
315 0         0 delete $self->{' nofilt'};
316             #delete $self->{' stream'};
317 0         0 $dict->{' stream'} = '';
318 0         0 $self->{' stream'} = '';
319             # dict->stream is the outer dict if notrans, and the Alpha data
320             # moved to it is simply unused
321             # dict->stream is the inner dict (created if !notrans), and the
322             # Alpha data moved to it becomes the SMask
323             # rebuild self->stream from the gray data in clearstream
324 0         0 foreach my $n (0 .. $h*$w-1) {
325 0         0 vec($dict->{' stream'}, $n, $bpc) = vec($clearstream, $n*2+1, $bpc);
326 0         0 vec($self->{' stream'}, $n, $bpc) = vec($clearstream, $n*2, $bpc);
327             }
328             }
329             } elsif ($cs == 6) { # RGB+alpha 8 bps (16 not supported here)
330             # transparency via tRNS chunk NOT allowed
331 2 50       6 if ($bpc > 8) {
332 0         0 die ">8 bits of RGB+alpha in PNG is not supported.";
333             } else {
334 2         10 $self->filters('FlateDecode');
335 2         9 $self->colorspace('DeviceRGB');
336 2         8 $self->bits_per_component($bpc);
337 2         7 my $dict = PDFDict();
338 2         7 $self->{'DecodeParms'} = PDFArray($dict);
339             # $dict->{'Predictor'} = PDFNum(15);
340 2         5 $dict->{'BitsPerComponent'} = PDFNum($bpc);
341 2         5 $dict->{'Colors'} = PDFNum(3);
342 2         7 $dict->{'Columns'} = PDFNum($w);
343              
344 2         5 $dict = PDFDict();
345 2 50       6 unless ($opts{'notrans'}) {
346 2         9 $pdf->new_obj($dict);
347 2         7 $dict->{'Type'} = PDFName('XObject');
348 2         6 $dict->{'Subtype'} = PDFName('Image');
349 2         5 $dict->{'Width'} = PDFNum($w);
350 2         6 $dict->{'Height'} = PDFNum($h);
351 2         5 $dict->{'ColorSpace'} = PDFName('DeviceGray');
352 2         6 $dict->{'Filter'} = PDFArray(PDFName('FlateDecode'));
353 2         15 $dict->{'BitsPerComponent'} = PDFNum($bpc);
354 2         5 $self->{'SMask'} = $dict;
355             }
356             # bytes per pixel (4 samples) and length of row scanline in bytes
357 2         16 my $scanline = 1 + ceil($bpc*4 * $w/8);
358 2         6 my $bpp = ceil($bpc*4 /8);
359             # unpacked, uncompressed, unfiltered image data
360 2         11 my $clearstream = unprocess($bpc, $bpp, 4, $w,$h, $scanline, \$self->{' stream'});
361 2         26 delete $self->{' nofilt'};
362             #delete $self->{' stream'};
363 2         14 $dict->{' stream'} = '';
364 2         12 $self->{' stream'} = '';
365             # as with cs=4, create SMask of Alpha entry for each pixel. this
366             # time, separating Alpha from RGB triplet and put in dict->stream
367             # dict->stream is the outer dict if notrans, and the Alpha data
368             # moved to it is simply unused
369             # dict->stream is the inner dict (created if !notrans), and the
370             # Alpha data moved to it becomes the SMask
371             # rebuild self->stream from the RGB data in clearstream 1/3 smaller
372 2         16 foreach my $n (0 .. ($h*$w)-1) {
373             # pull out Alpha data bpc bits into new dict SMask
374 218120         355271 vec($dict->{' stream'}, $n, $bpc) = vec($clearstream, $n*4+3, $bpc);
375             # transfer RGB triplet into self->stream
376 218120         385230 vec($self->{' stream'}, $n*3, $bpc) = vec($clearstream, $n*4, $bpc);
377 218120         380519 vec($self->{' stream'}, $n*3+1, $bpc) = vec($clearstream, $n*4+1, $bpc);
378 218120         426465 vec($self->{' stream'}, $n*3+2, $bpc) = vec($clearstream, $n*4+2, $bpc);
379             }
380             }
381             } else {
382 0         0 die "unsupported PNG-color type (cs=$cs).";
383             }
384              
385 4         66 return($self);
386             }
387              
388             =over
389              
390             =item $mode = $png->usesLib()
391              
392             Returns 1 if Image::PNG::Libpng installed and used, 0 if not installed, or -1
393             if installed but not used (nouseIPL option given to C).
394              
395             B this method can only be used I the image object has been
396             created. It can't tell you whether Image::PNG::Libpng is available in
397             advance of actually using it, in case you want to use some functionality
398             available only in PNG_IPL. See the L LA_IPL() call if you
399             need to know in advance.
400              
401             =back
402              
403             =cut
404              
405             sub usesLib {
406 3     3 1 21 my ($self) = shift;
407             # should be 0 for Image::PNG::Libpng not installed, or -1 for is installed,
408             # but not using it
409 3         14 return $self->{'usesIPL'}->val();
410             }
411              
412             sub PaethPredictor {
413 94240     94240 0 161476 my ($a, $b, $c) = @_;
414 94240         118952 my $p = $a + $b - $c;
415 94240         109618 my $pa = abs($p - $a);
416 94240         104985 my $pb = abs($p - $b);
417 94240         103387 my $pc = abs($p - $c);
418 94240 100 100     205681 if (($pa <= $pb) && ($pa <= $pc)) {
    100          
419 82304         222954 return $a;
420             } elsif ($pb <= $pc) {
421 11154         28801 return $b;
422             } else {
423 782         2138 return $c;
424             }
425             }
426              
427             sub unprocess {
428 2     2 0 6 my ($bpc, $bpp, $comp, $width,$height, $scanline, $sstream) = @_;
429              
430 2         13 my $stream = uncompress($$sstream);
431 2         4395 my $prev = '';
432 2         6 my $clearstream = '';
433 2         12 foreach my $n (0 .. $height-1) {
434             # print STDERR "line $n:";
435 574         3375 my $line = substr($stream, $n*$scanline, $scanline);
436 574         1049 my $filter = vec($line, 0, 8);
437 574         1117 my $clear = '';
438 574         1139 $line = substr($line, 1);
439             # print STDERR " filter=$filter";
440 574 50       2759 if ($filter == 0) {
    100          
    100          
    50          
    50          
441 0         0 $clear = $line;
442             } elsif ($filter == 1) {
443 18         61 foreach my $x (0 .. length($line)-1) {
444 27360         47133 vec($clear, $x, 8) = (vec($line, $x, 8) + vec($clear, $x-$bpp, 8))%256;
445             }
446             } elsif ($filter == 2) {
447 494         1608 foreach my $x (0 .. length($line)-1) {
448 750880         1260341 vec($clear, $x, 8) = (vec($line, $x, 8) + vec($prev, $x, 8))%256;
449             }
450             } elsif ($filter == 3) {
451 0         0 foreach my $x (0 .. length($line)-1) {
452 0         0 vec($clear, $x, 8) = (vec($line, $x, 8) + floor((vec($clear, $x-$bpp, 8) + vec($prev, $x, 8))/2))%256;
453             }
454             } elsif ($filter == 4) {
455 62         211 foreach my $x (0 .. length($line)-1) {
456 94240         205536 vec($clear, $x, 8) = (vec($line, $x, 8) + PaethPredictor(vec($clear, $x-$bpp, 8), vec($prev, $x, 8), vec($prev, $x-$bpp, 8)))%256;
457             }
458             }
459 574         1584 $prev = $clear;
460 574         1806 foreach my $x (0 .. ($width*$comp)-1) {
461 872480         1437455 vec($clearstream, ($n*$width*$comp)+$x, $bpc) = vec($clear, $x, $bpc);
462             # print STDERR "".vec($clear,$x,$bpc).",";
463             }
464             # print STDERR "\n";
465             }
466 2         1165 return $clearstream;
467             }
468              
469             1;
470              
471             __END__