File Coverage

blib/lib/PDF/Builder/Resource/XObject/Image/GIF.pm
Criterion Covered Total %
statement 102 194 52.5
branch 19 46 41.3
condition 4 15 26.6
subroutine 9 10 90.0
pod 1 3 33.3
total 135 268 50.3


line stmt bran cond sub pod time code
1             package PDF::Builder::Resource::XObject::Image::GIF;
2              
3 2     2   1158 use base 'PDF::Builder::Resource::XObject::Image';
  2         6  
  2         644  
4              
5 2     2   16 use strict;
  2         6  
  2         44  
6 2     2   9 use warnings;
  2         6  
  2         101  
7             #no warnings qw[ deprecated recursion uninitialized ];
8              
9             our $VERSION = '3.023'; # VERSION
10             our $LAST_UPDATE = '3.021'; # manually update whenever code is changed
11              
12 2     2   12 use IO::File;
  2         4  
  2         354  
13 2     2   23 use PDF::Builder::Util;
  2         5  
  2         307  
14 2     2   16 use PDF::Builder::Basic::PDF::Utils;
  2         13  
  2         188  
15 2     2   16 use Scalar::Util qw(weaken);
  2         5  
  2         3429  
16              
17             =head1 NAME
18              
19             PDF::Builder::Resource::XObject::Image::GIF - support routines for GIF image library. Inherits from L
20              
21             =head1 Supported Formats
22              
23             GIF87a and GIF89a headers are supported. The Image block (x2C) is supported.
24              
25             The Graphic Control Extension block (x21 + xF9) is supported for transparency
26             control. Animation is not supported.
27              
28             The Comment Extension block (x21 + xFE), Plain Text Extension block (x21 + x01),
29             and Application Extension block (x21 + xFF) are read, but ignored. Any other
30             block or Extension block will be flagged as an error.
31              
32             If given, Local Color Tables are read and used, supposedly permitting more
33             than 256 colors to be used overall in the image (despite the 8 bit color table
34             depth).
35              
36             A fairly thorough description of the GIF format may be found in
37             L.
38              
39             =head2 Options
40              
41             =over
42              
43             =item -notrans
44              
45             When defined and not 0, C<-notrans> suppresses the use of transparency if such
46             is defined in the GIF file.
47              
48             =item -multi
49              
50             When defined and not 0, C<-multi> continues processing past the end of the
51             first Image Block. The old behavior, which is now the default, is to stop
52             processing at the end of the first Image Block.
53              
54             =back
55              
56             =cut
57              
58             # added from PDF::Create:
59             # PDF::Image::GIFImage - GIF image support
60             # Author: Michael Gross
61             # modified for internal use. (c) 2004 fredo.
62             sub unInterlace {
63 0     0 0 0 my $self = shift;
64              
65 0         0 my $data = $self->{' stream'};
66 0         0 my $row;
67             my @result;
68 0         0 my $width = $self->width();
69 0         0 my $height = $self->height();
70 0         0 my $idx = 0;
71              
72             #Pass 1 - every 8th row, starting with row 0
73 0         0 $row = 0;
74 0         0 while ($row < $height) {
75 0         0 $result[$row] = substr($data, $idx*$width, $width);
76 0         0 $row += 8;
77 0         0 $idx++;
78             }
79              
80             #Pass 2 - every 8th row, starting with row 4
81 0         0 $row = 4;
82 0         0 while ($row < $height) {
83 0         0 $result[$row] = substr($data, $idx*$width, $width);
84 0         0 $row += 8;
85 0         0 $idx++;
86             }
87              
88             #Pass 3 - every 4th row, starting with row 2
89 0         0 $row = 2;
90 0         0 while ($row < $height) {
91 0         0 $result[$row] = substr($data, $idx*$width, $width);
92 0         0 $row += 4;
93 0         0 $idx++;
94             }
95              
96             #Pass 4 - every 2nd row, starting with row 1
97 0         0 $row = 1;
98 0         0 while ($row < $height) {
99 0         0 $result[$row] = substr($data, $idx*$width, $width);
100 0         0 $row += 2;
101 0         0 $idx++;
102             }
103              
104 0         0 return $self->{' stream'} = join('', @result);
105             }
106              
107             sub deGIF {
108 2     2 0 5 my ($ibits, $stream) = @_;
109              
110 2         3 my $bits = $ibits;
111 2         5 my $resetcode = 1 << ($ibits-1);
112 2         4 my $endcode = $resetcode+1;
113 2         4 my $nextcode = $endcode+1;
114 2         2 my $ptr = 0;
115 2         4 my $maxptr = 8*length($stream);
116 2         5 my $tag;
117 2         3 my $out = '';
118 2         3 my $outptr = 0;
119              
120             # print STDERR "reset=$resetcode\nend=$endcode\nmax=$maxptr\n";
121              
122 2         6 my @d = map { chr($_) } (0 .. $resetcode-1);
  8         33  
123              
124 2         9 while ($ptr+$bits <= $maxptr) {
125 6         8 $tag = 0;
126 6         13 foreach my $off (reverse 0 .. $bits-1) {
127 18         33 $tag <<= 1;
128 18         31 $tag |= vec($stream, $ptr+$off, 1);
129             }
130             # foreach my $off (0 .. $bits-1) {
131             # $tag <<= 1;
132             # $tag |= vec($stream, $ptr+$off, 1);
133             # }
134             # print STDERR "ptr=$ptr,tag=$tag,bits=$bits,next=$nextcode\n";
135             # print STDERR "tag to large\n" if($tag>$nextcode);
136 6         10 $ptr += $bits;
137 6 50 33     17 $bits++ if $nextcode == 1 << $bits and $bits < 12;
138 6 100       20 if ($tag == $resetcode) {
    100          
    50          
    0          
139 2         4 $bits = $ibits;
140 2         4 $nextcode = $endcode+1;
141 2         6 next;
142             } elsif ($tag == $endcode) {
143 2         6 last;
144             } elsif ($tag < $resetcode) {
145 2         5 $d[$nextcode] = $d[$tag];
146 2         7 $out .= $d[$nextcode];
147 2         5 $nextcode++;
148             } elsif ($tag > $endcode) {
149 0         0 $d[$nextcode] = $d[$tag];
150 0         0 $d[$nextcode] .= substr($d[$tag+1], 0, 1);
151 0         0 $out .= $d[$nextcode];
152 0         0 $nextcode++;
153             }
154             }
155 2         8 return $out;
156             }
157              
158             sub new {
159 3     3 1 9 my ($class, $pdf, $file, $name, %opts) = @_;
160              
161 3         6 my $self;
162              
163 3         5 my $inter = 0;
164              
165 3 50       10 $class = ref $class if ref $class;
166              
167 3   33     18 $self = $class->SUPER::new($pdf, $name || 'Gx'.pdfkey());
168 3 50       9 $pdf->new_obj($self) unless $self->is_obj($pdf);
169              
170 3         6 $self->{' apipdf'} = $pdf;
171 3         9 weaken $self->{' apipdf'};
172              
173 3         16 my $fh = IO::File->new();
174 3 100       112 if (ref($file)) {
175 1         3 $fh = $file;
176             } else {
177 2 100       128 open $fh, "<", $file or die "$!: $file";
178             }
179 2         26 binmode $fh, ':raw';
180 2         7 my $buf;
181 2         20 $fh->seek(0, 0);
182              
183             # start reading in the GIF file
184             # GIF Header
185             # 6 bytes "GIF87a" or "GIF89a"
186 2         45 $fh->read($buf, 6); # signature
187 2 50       67 die "unknown image signature '$buf' -- not a GIF." unless $buf =~ /^GIF[0-9][0-9][a-b]/; # TBD b? is anything other than 87a and 89a valid?
188              
189             # 4 bytes logical screen width and height (2 x 16 bit LSB first)
190             # 1 byte flags, 1 byte background color index, 1 byte pixel aspect ratio
191 2         10 $fh->read($buf, 7); # logical descr.
192 2         19 my($wg, $hg, $flags, $bgColorIndex, $aspect) = unpack('vvCCC', $buf);
193              
194             # flags numbered left to right 0-7:
195             # bit 0 = 1 (x80) Global Color Table Flag (GCTF)
196             # bits 1-3 = color resolution
197             # bit 4 = 1 (x08) sort flag for Global Color Table
198             # bits 5-7 = size of Global Color Table 2**(n+1), $colSize
199 2 50       7 if ($flags & 0x80) { # GCTF is set?
200 2         6 my $colSize = 2**(($flags & 0x7)+1); # 2 - 256 entries
201 2         7 my $dict = PDFDict();
202 2         8 $pdf->new_obj($dict);
203 2         7 $self->colorspace(PDFArray(PDFName('Indexed'), PDFName('DeviceRGB'), PDFNum($colSize-1), $dict));
204 2         11 $fh->read($dict->{' stream'}, 3*$colSize); # Global Color Table
205             }
206              
207             # further content in file is blocks and trailer
208 2         27 while (!$fh->eof()) {
209 2         20 $fh->read($buf, 1); # 1 byte block tag (type)
210 2         12 my $sep = unpack('C', $buf);
211              
212 2 50       8 if ($sep == 0x2C) {
    0          
    0          
213             # x2C = image block (separator, equals ASCII comma ',')
214 2         5 $fh->read($buf, 9); # image-descr.
215             # image left (16 bits), image top (16 bits LSB first)
216             # image width (16 bits), image height (16 bits LSB first)
217             # flags (1 byte):
218             # bit 0 = 1 (x80) Local Color Table Flag (LCTF)
219             # bit 1 = 1 (x40) interlaced
220             # bit 2 = 1 (x20) sort flag
221             # bits 3-4 = reserved
222             # bits 5-7 = size of Local Color Table 2**(n+1) if LCTF=1
223 2         12 my ($left, $top, $w,$h, $flags) = unpack('vvvvC', $buf);
224              
225 2   33     26 $self->width($w||$wg);
226 2   33     10 $self->height($h||$hg);
227 2         7 $self->bits_per_component(8);
228              
229 2 50       7 if ($flags & 0x80) { # Local Color Table (LCTF = 1)
230 0         0 my $colSize = 2**(($flags & 0x7)+1);
231 0         0 my $dict = PDFDict();
232 0         0 $pdf->new_obj($dict);
233 0         0 $self->colorspace(PDFArray(PDFName('Indexed'), PDFName('DeviceRGB'), PDFNum($colSize-1), $dict));
234 0         0 $fh->read($dict->{' stream'}, 3*$colSize); # Local Color Table
235             }
236 2 50       5 if ($flags & 0x40) { # need de-interlace
237 0         0 $inter = 1; # default to 0 earlier
238             }
239              
240             # LZW Minimum Code Size
241 2         7 $fh->read($buf, 1); # image-lzw-start (should be 9).
242 2         13 my ($sep) = unpack('C', $buf);
243              
244             # read one or more blocks. first byte is length.
245             # if 0, done (Block Terminator)
246 2         7 $fh->read($buf, 1); # first chunk.
247 2         12 my ($len) = unpack('C', $buf);
248 2         4 my $stream = '';
249 2         6 while ($len > 0) { # loop through blocks as long as non-0 length
250 2         9 $fh->read($buf, $len);
251 2         10 $stream .= $buf;
252 2         6 $fh->read($buf, 1);
253 2         12 $len = unpack('C', $buf);
254             }
255 2         8 $self->{' stream'} = deGIF($sep+1, $stream);
256 2 50       5 $self->unInterlace() if $inter;
257             # old (and current default) behavior is to quit processing at the
258             # end of the first Image Block. This means that any other blocks,
259             # including the Trailer, will not be processed.
260 2 50       7 if (!$opts{'-multi'}) { last; }
  2         4  
261              
262             } elsif ($sep == 0x3b) {
263             # trailer (EOF) equals ASCII semicolon (;)
264 0         0 last;
265              
266             } elsif ($sep == 0x21) {
267             # Extension block (x21 + subtag) = ASCII '!'
268 0         0 $fh->read($buf, 1); # tag.
269 0         0 my $tag = unpack('C', $buf);
270              
271 0 0       0 if ($tag == 0xF9) {
    0          
    0          
    0          
272             # xF9 graphic control extension block
273 0         0 $fh->read($buf, 1); # len. should be 04
274 0         0 my $len = unpack('C', $buf);
275 0         0 my $stream = '';
276 0         0 while ($len > 0) {
277 0         0 $fh->read($buf, $len);
278 0         0 $stream .= $buf;
279 0         0 $fh->read($buf, 1);
280 0         0 $len = unpack('C', $buf);
281             }
282 0         0 my ($cFlags, $delay, $transIndex) = unpack('CvC', $stream);
283 0 0 0     0 if (($cFlags & 0x01) && !$opts{'-notrans'}) {
284 0         0 $self->{'Mask'} = PDFArray(PDFNum($transIndex), PDFNum($transIndex));
285             }
286              
287             } elsif ($tag == 0xFE) {
288             # xFE comment extension block
289             # read comment data block(s) until 0 length
290             # currently just discard comment ($stream)
291 0         0 $fh->read($buf, 1); # len.
292 0         0 my $len = unpack('C', $buf);
293 0         0 my $stream = '';
294 0         0 while ($len > 0) {
295 0         0 $fh->read($buf, $len);
296 0         0 $stream .= $buf;
297 0         0 $fh->read($buf, 1);
298 0         0 $len = unpack('C', $buf);
299             }
300              
301             } elsif ($tag == 0x01) {
302             # x01 plain text extension block
303 0         0 $fh->read($buf, 13); # len.
304 0         0 my ($blkSize,$tgL,$tgT,$tgW,$tgH,$ccW,$ccH,$tFci,$tBci) =
305             unpack('CvvvvCCCC', $buf);
306              
307             # read plain text data block(s) until 0 length
308             # currently just discard comment ($stream)
309 0         0 $fh->read($buf, 1); # len.
310 0         0 my $len = unpack('C', $buf);
311 0         0 my $stream = '';
312 0         0 while ($len > 0) {
313 0         0 $fh->read($buf, $len);
314 0         0 $stream .= $buf;
315 0         0 $fh->read($buf, 1);
316 0         0 $len = unpack('C', $buf);
317             }
318              
319             } elsif ($tag == 0xFF) {
320             # xFF application extension block
321 0         0 $fh->read($buf, 1);
322 0         0 my $blkSize = unpack('C', $buf);
323 0         0 $fh->read($buf, 8);
324 0         0 my $appID = unpack('C8', $buf);
325              
326 0         0 $fh->read($buf, 1); # len.
327 0         0 my $len = unpack('C', $buf);
328 0         0 my $stream = '';
329 0         0 while ($len > 0) {
330 0         0 $fh->read($buf, $len);
331 0         0 $stream .= $buf;
332 0         0 $fh->read($buf, 1);
333 0         0 $len = unpack('C', $buf);
334             }
335              
336             } else {
337 0         0 print "unsupported extension block (".
338             sprintf("0x%02X",$tag).") ignored!\n";
339             }
340              
341             } else {
342             # other extensions and blocks (ignored)
343 0         0 print "unsupported extension or block (".
344             sprintf("0x%02X",$sep).") ignored.\n";
345              
346 0         0 $fh->read($buf, 1); # tag.
347 0         0 my $tag = unpack('C', $buf);
348 0         0 $fh->read($buf, 1); # tag.
349 0         0 my $len = unpack('C', $buf);
350 0         0 while ($len > 0) {
351 0         0 $fh->read($buf, $len);
352 0         0 $fh->read($buf, 1);
353 0         0 $len = unpack('C', $buf);
354             }
355             }
356             }
357 2         12 $fh->close();
358              
359 2         64 $self->filters('FlateDecode');
360              
361 2         10 return $self;
362             }
363              
364             1;