File Coverage

blib/lib/Text/PDF/Filter.pm
Criterion Covered Total %
statement 30 203 14.7
branch 0 72 0.0
condition 0 15 0.0
subroutine 10 24 41.6
pod 1 2 50.0
total 41 316 12.9


line stmt bran cond sub pod time code
1             package Text::PDF::Filter;
2              
3             =head1 NAME
4              
5             PDF::Filter - Abstract superclass for PDF stream filters
6              
7             =head1 SYNOPSIS
8              
9             $f = Text::PDF::Filter->new;
10             $str = $f->outfilt($str, 1);
11             print OUTFILE $str;
12            
13             while (read(INFILE, $dat, 4096))
14             { $store .= $f->infilt($dat, 0); }
15             $store .= $f->infilt("", 1);
16              
17             =head1 DESCRIPTION
18              
19             A Filter object contains state information for the process of outputting
20             and inputting data through the filter. The precise state information stored
21             is up to the particular filter and may range from nothing to whole objects
22             created and destroyed.
23              
24             Each filter stores different state information for input and output and thus
25             may handle one input filtering process and one output filtering process at
26             the same time.
27              
28             =head1 METHODS
29              
30             =head2 Text::PDF::Filter->new
31              
32             Creates a new filter object with empty state information ready for processing
33             data both input and output.
34              
35             =head2 $dat = $f->infilt($str, $isend)
36              
37             Filters from output to input the data. Notice that $isend == 0 implies that there
38             is more data to come and so following it $f may contain state information
39             (usually due to the break-off point of $str not being tidy). Subsequent calls
40             will incorporate this stored state information.
41              
42             $isend == 1 implies that there is no more data to follow. The
43             final state of $f will be that the state information is empty. Error messages
44             are most likely to occur here since if there is required state information to
45             be stored following this data, then that would imply an error in the data.
46              
47             =head2 $str = $f->outfilt($dat, $isend)
48              
49             Filter stored data ready for output. Parallels C.
50              
51             =cut
52              
53             sub new
54             {
55 0     0 1   my ($class) = @_;
56 0           my ($self) = {};
57              
58 0           bless $self, $class;
59             }
60              
61             sub release
62             {
63 0     0 0   my ($self) = @_;
64              
65             # delete stuff that we know we can, here
66              
67 0           my @tofree = map { delete $self->{$_} } keys %{$self};
  0            
  0            
68              
69 0           while (my $item = shift @tofree)
70             {
71 0           my $ref = ref($item);
72 0 0         if (UNIVERSAL::can($item, 'release'))
    0          
    0          
73 0           { $item->release(); }
74             elsif ($ref eq 'ARRAY')
75 0           { push( @tofree, @{$item} ); }
  0            
76             elsif (UNIVERSAL::isa($ref, 'HASH'))
77 0           { release($item); }
78             }
79              
80             # check that everything has gone - it better had!
81 0           foreach my $key (keys %{$self})
  0            
82 0           { warn ref($self) . " still has '$key' key left after release.\n"; }
83             }
84              
85              
86             package Text::PDF::ASCII85Decode;
87              
88 1     1   3 use strict;
  1         1  
  1         23  
89 1     1   3 use vars qw(@ISA);
  1         0  
  1         482  
90             @ISA = qw(Text::PDF::Filter);
91             # no warnings qw(uninitialized);
92              
93             =head1 NAME
94              
95             Text::PDF::ASCII85Decode - Ascii85 filter for PDF streams. Inherits from
96             L
97              
98             =cut
99              
100             sub outfilt
101             {
102 0     0     my ($self, $str, $isend) = @_;
103 0           my ($res, $i, $j, $b, @c);
104              
105 0 0         if ($self->{'outcache'} ne "")
106             {
107 0           $str = $self->{'outcache'} . $str;
108 0           $self->{'outcache'} = "";
109             }
110 0           for ($i = 0; $i < length($str); $i += 4)
111             {
112 0           $b = unpack("N", substr($str, $i, 4));
113 0 0         if ($b == 0)
114             {
115 0           $res .= "z";
116 0           next;
117             }
118 0           for ($j = 3; $j >= 0; $j--)
119 0           { $c[$j] = $b - int($b / 85) * 85 + 33; $b /= 85; }
  0            
120 0           $res .= pack("C5", $b + 33, @c);
121 0 0         $res .= "\n" if ($i % 60 == 56);
122             }
123 0 0 0       if ($isend && $i > length($str))
    0          
124             {
125 0           $b = unpack("N", substr($str, $i - 4) . "\000\000\000");
126 0           for ($j = 0; $j < 4; $j++)
127 0           { $c[$j] = $b - int($b / 85) * 85 + 33; $b /= 85; }
  0            
128 0           $res .= substr(pack("C5", @c, $b), 0, $i - length($str) + 1) . "->";
129             } elsif ($i > length($str))
130 0           { $self->{'outcache'} = substr($str, $i - 4); }
131 0           $res;
132             }
133              
134             sub infilt
135             {
136 0     0     my ($self, $str, $isend) = @_;
137 0           my ($res, $i, $j, @c, $b, $num);
138              
139 0 0         if ($self->{'incache'} ne "")
140             {
141 0           $str = $self->{'incache'} . $str;
142 0           $self->{'incache'} = "";
143             }
144 0           $str =~ s/(\r|\n)\n?//og;
145 0           for ($i = 0; $i < length($str); $i += 5)
146             {
147 0           $b = 0;
148 0 0 0       if (substr($str, $i, 1) eq "z")
    0          
149             {
150 0           $i -= 4;
151 0           $res .= pack("N", 0);
152 0           next;
153             }
154             elsif ($isend && substr($str, $i, 6) =~ m/^(.{2,4})\~\>$/o)
155             {
156 0           $num = 5 - length($1);
157 0           @c = unpack("C5", $1 . ("u" x (4 - $num))); # pad with 84 to sort out rounding
158 0           $i = length($str);
159             } else
160 0           { @c = unpack("C5", substr($str, $i, 5)); }
161              
162 0           for ($j = 0; $j < 5; $j++)
163             {
164 0           $b *= 85;
165 0           $b += $c[$j] - 33;
166             }
167 0           $res .= substr(pack("N", $b), 0, 4 - $num);
168             }
169 0 0 0       if (!$isend && $i > length($str))
170 0           { $self->{'incache'} = substr($str, $i - 5); }
171 0           $res;
172             }
173              
174              
175              
176             package Text::PDF::RunLengthDecode;
177              
178 1     1   4 use strict;
  1         1  
  1         19  
179 1     1   2 use vars qw(@ISA);
  1         1  
  1         293  
180             @ISA = qw(Text::PDF::Filter);
181             # no warnings qw(uninitialized);
182              
183             =head1 NAME
184              
185             Text::PDF::RunLengthDecode - Run Length encoding filter for PDF streams. Inherits from
186             L
187              
188             =cut
189              
190             sub outfilt
191             {
192 0     0     my ($self, $str, $isend) = @_;
193 0           my ($res, $s, $r);
194              
195             # no state information, just slight inefficiency at block boundaries
196 0           while ($str ne "")
197             {
198 0 0         if ($str =~ m/^(.*?)((.)\2{2,127})(.*?)$/so)
199             {
200 0           $s = $1;
201 0           $r = $2;
202 0           $str = $3;
203             } else
204             {
205 0           $s = $str;
206 0           $r = '';
207 0           $str = '';
208             }
209 0           while (length($s) > 127)
210             {
211 0           $res .= pack("C", 127) . substr($s, 0, 127);
212 0           substr($s, 0, 127) = '';
213             }
214 0 0         $res .= pack("C", length($s)) . $s if length($s) > 0;
215 0           $res .= pack("C", 257 - length($r));
216             }
217 0 0         $res .= "\x80" if ($isend);
218 0           $res;
219             }
220              
221             sub infilt
222             {
223 0     0     my ($self, $str, $isend) = @_;
224 0           my ($res, $l, $d);
225              
226 0 0         if ($self->{'incache'} ne "")
227             {
228 0           $str = $self->{'incache'} . $str;
229 0           $self->{'incache'} = "";
230             }
231 0           while ($str ne "")
232             {
233 0           $l = unpack("C", $str);
234 0 0         if ($l == 128)
235             {
236 0           $isend = 1;
237 0           return $res;
238             }
239 0 0         if ($l > 128)
240             {
241 0 0         if (length($str) < 2)
242             {
243 0 0         warn "Premature end to data in RunLengthEncoded data" if $isend;
244 0           $self->{'incache'} = $str;
245 0           return $res;
246             }
247 0           $res .= substr($str, 1, 1) x (257 - $l);
248 0           substr($str, 0, 2) = "";
249             } else
250             {
251 0 0         if (length($str) < $l + 1)
252             {
253 0 0         warn "Premature end to data in RunLengthEncoded data" if $isend;
254 0           $self->{'incache'} = $str;
255 0           return $res;
256             }
257 0           $res .= substr($str, 1, $l);
258 0           substr($str, 0, $l + 1) = "";
259             }
260             }
261 0           $res;
262             }
263              
264              
265              
266             package Text::PDF::ASCIIHexDecode;
267              
268 1     1   6 use strict;
  1         0  
  1         18  
269 1     1   10 use vars qw(@ISA);
  1         1  
  1         197  
270             @ISA = qw(Text::PDF::Filter);
271             # no warnings qw(uninitialized);
272              
273             =head1 NAME
274              
275             Text::PDF::ASCIIHexDecode - Ascii Hex encoding (very inefficient) for PDF streams.
276             Inherits from L
277              
278             =cut
279              
280             sub outfilt
281             {
282 0     0     my ($self, $str, $isend) = @_;
283              
284 0           $str =~ s/(.)/sprintf("%02x", ord($1))/oge;
  0            
285 0 0         $str .= ">" if $isend;
286 0           $str;
287             }
288              
289             sub infilt
290             {
291 0     0     my ($self, $str, $isend) = @_;
292              
293 0           $isend = ($str =~ s/>$//og);
294 0           $str =~ s/\s//oig;
295 0 0 0       $str =~ s/([0-9a-z])/pack("C", hex($1 . "0"))/oige if ($isend && length($str) & 1);
  0            
296 0           $str =~ s/([0-9a-z]{2})/pack("C", hex($1))/oige;
  0            
297 0           $str;
298             }
299              
300             package Text::PDF::FlateDecode;
301              
302 1     1   4 use strict;
  1         1  
  1         21  
303 1     1   2 use vars qw(@ISA $havezlib);
  1         1  
  1         47  
304             @ISA = qw(Text::PDF::Filter);
305             BEGIN
306             {
307 1     1   2 eval {require "Compress/Zlib.pm";};
  1         575  
308 1         40546 $havezlib = !$@;
309             }
310              
311             sub new
312             {
313 0 0   0     return undef unless $havezlib;
314 0           my ($class) = @_;
315 0           my ($self) = {};
316              
317 0           $self->{'outfilt'} = Compress::Zlib::deflateInit();
318 0           $self->{'infilt'} = Compress::Zlib::inflateInit();
319 0           bless $self, $class;
320             }
321              
322             sub outfilt
323             {
324 0     0     my ($self, $str, $isend) = @_;
325 0           my ($res);
326              
327 0           $res = $self->{'outfilt'}->deflate($str);
328 0 0         $res .= $self->{'outfilt'}->flush() if ($isend);
329 0           $res;
330             }
331              
332             sub infilt
333             {
334 0     0     my ($self, $dat, $last) = @_;
335 0           my ($res, $status) = $self->{'infilt'}->inflate("$dat");
336 0           $res;
337             }
338              
339             package Text::PDF::LZWDecode;
340              
341 1     1   6 use vars qw(@ISA @basedict);
  1         1  
  1         466  
342             @ISA = qw(Text::PDF::FlateDecode);
343             @basedict = map {pack("C", $_)} (0 .. 255, 0, 0);
344             # no warnings qw(uninitialized);
345              
346             sub new
347             {
348 0     0     my ($class) = @_;
349 0           my ($self) = {};
350              
351 0           $self->{'indict'} = [@basedict];
352 0           $self->{'count'} = 258;
353 0           $self->{'insize'} = 9;
354 0           $self->{'cache'} = 0;
355 0           $self->{'cache_size'} = 0;
356             # $self->{'outfilt'} = Compress::Zlib::deflateInit(); # patent precludes LZW encoding
357 0           bless $self, $class;
358             }
359              
360             sub infilt
361             {
362 0     0     my ($self, $dat, $last) = @_;
363 0           my ($num, $res);
364              
365 0           $res = '';
366              
367 0   0       while ($dat ne '' || $self->{'cache_size'} >= $self->{'insize'})
368             {
369 0           $num = $self->read_dat(\$dat);
370 0 0         last if $num < 0;
371 0 0         return $res if ($num == 257); # End of Data
372 0 0         if ($num == 256) # Clear table
373             {
374 0           $self->{'indict'} = [@basedict];
375 0           $self->{'insize'} = 9;
376 0           $self->{'count'} = 258;
377 0           next;
378             }
379 0 0         if ($self->{'count'} > 258)
380             {
381 0           ($self->{'indict'}[$self->{'count'}-1]) .= substr($self->{'indict'}[$num], 0, 1);
382             }
383 0 0         if ($self->{'count'} < 4096)
384             {
385 0           $self->{'indict'}[$self->{'count'}] = $self->{'indict'}[$num];
386 0           $self->{'count'}++;
387             }
388 0           $res .= $self->{'indict'}[$num];
389 0 0         if ($self->{'count'} >= 4096)
    0          
    0          
    0          
390             {
391             # don't do anything on table full, the encoder tells us when to clear
392             } elsif ($self->{'count'} == 512)
393 0           { $self->{'insize'} = 10; }
394             elsif ($self->{'count'} == 1024)
395 0           { $self->{'insize'} = 11; }
396             elsif ($self->{'count'} == 2048)
397 0           { $self->{'insize'} = 12; }
398             }
399 0           return $res;
400             }
401              
402             sub read_dat
403             {
404 0     0     my ($self, $rdat) = @_;
405 0           my ($res);
406              
407 0           while ($self->{'cache_size'} < $self->{'insize'})
408             {
409 0 0         return -1 if $$rdat eq ''; # oops -- not enough data in this chunk
410 0           $self->{'cache'} = ($self->{'cache'} << 8) + unpack("C", $$rdat);
411 0           substr($$rdat, 0, 1) = '';
412 0           $self->{'cache_size'} += 8;
413             }
414              
415 0           $res = $self->{'cache'} >> ($self->{'cache_size'} - $self->{'insize'});
416 0           $self->{'cache'} &= (1 << ($self->{'cache_size'} - $self->{'insize'})) - 1;
417 0           $self->{'cache_size'} -= $self->{'insize'};
418 0           return $res;
419             }
420              
421             1;
422