File Coverage

blib/lib/PDF/Builder/Resource/XObject/Image/PNG.pm
Criterion Covered Total %
statement 83 243 34.1
branch 22 68 32.3
condition 2 15 13.3
subroutine 11 13 84.6
pod 2 4 50.0
total 120 343 34.9


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