File Coverage

blib/lib/Compress/Zlib/Perl.pm
Criterion Covered Total %
statement 261 281 92.9
branch 78 98 79.6
condition 13 23 56.5
subroutine 31 34 91.2
pod 0 23 0.0
total 383 459 83.4


line stmt bran cond sub pod time code
1             package Compress::Zlib::Perl;
2              
3 1     1   78 use 5.004;
  1         9  
  1         9  
4              
5             # use if $] > 5.006, 'warnings';
6             # use warnings;
7 1     1   66 use strict;
  1         8  
  1         16  
8              
9             require Exporter;
10              
11 1     1   15 use vars qw($VERSION @ISA @EXPORT);
  1         9  
  1         71  
12             @ISA = qw(Exporter);
13              
14             # Items to export into callers namespace by default. Note: do not export
15             # names by default without a very good reason. Use EXPORT_OK instead.
16             # Do not simply export all your public functions/methods/constants.
17              
18 1     1   16 use constant Z_OK => 0;
  1         8  
  1         16  
19 1     1   66 use constant Z_STREAM_END => 1;
  1         9  
  1         11  
20 1     1   14 use constant MAX_WBITS => 16;
  1         9  
  1         11  
21              
22             @EXPORT = qw(
23             Z_OK Z_STREAM_END MAX_WBITS crc32
24             );
25              
26             $VERSION = '0.02';
27              
28             {
29               my @crc32;
30              
31               sub _init_crc32 {
32             # I'm not sure why Ton wanted to reverse the order of the bits in this
33             # constant, rather than using the bit-reversed constant
34             # my $p=oct reverse sprintf"%032bb0", 0x04C11DB7;
35             # But the only 5.005 friendly way I can find is this:
36 1     1   46     my $p
37                   = unpack "I", pack "b*", scalar reverse unpack "b*", pack "I", 0x04C11DB7;
38 1   66     11     @crc32 = map{for my$s(0..7) {$_ = $_>>1 ^ ($_&1 && $p)} $_} 0..255;
  256         2226  
  2048         29872  
  256         2684  
39               }
40              
41             # Calculate gzip header 16 bit CRCs
42               sub _crc16 {
43 0     0   0     my $crc16 = shift;
44 0 0       0     _init_crc32() unless @crc32;
45 0         0     foreach my $input (@_) {
46             # I have no way to test this, as nothing that I can find generates
47             # gzip files with the header CRC.
48             # Ton's code is this:
49                   $crc16 = $crc16>>8^$crc32[$crc16&0xff^ord(substr $input,$_,1)]
50 0         0 for 0..length($input)-1;
  0         0  
51             # I believe that the following is functionally equivalent, but should
52             # be faster:
53             # while ($input =~ /(.)/gs) {
54             # $crc16 = $crc16 >> 8 ^ $crc32[$crc16 & 0xff ^ ord $1];
55             # }
56 0         0       return $crc16;
57                 }
58               }
59              
60             # Public interface starts here:
61              
62             # Calculate 32 bit CRCs
63               sub crc32 {
64 7411 100   7411 0 88650     _init_crc32() unless @crc32;
65 7411         87187     my ($buffer, $crc32) = @_;
66 7411   50     87780     $crc32 ||= 0;
67 7411         78766     $crc32 ^= 0xffffffff;
68 7411         84606     my $pos = -length $buffer;
69 7411         227486     $crc32 = $crc32>>8 ^ $crc32[$crc32&0xff^ord(substr($buffer, $pos++, 1))]
70                   while $pos;
71 7411         95349     $crc32 ^ 0xffffffff;
72               }
73             }
74              
75             sub inflateInit {
76 8     8 0 102   my %args = @_;
77 8 50 33     146   die "Please specify negative window size"
78                 unless $args{-WindowBits} && $args{-WindowBits} < 0;
79 8         134   my $self = bless {isize=>0,
80             osize=>0,
81             result=>"",
82             huffman=>"",
83             type0length=>"",
84             state=>\&stateReadFinal
85             };
86 8         102   $self->_reset_bits_have;
87 8 50       114   wantarray ? ($self, Z_OK) : $self;
88             }
89              
90             sub total_in {
91 0     0 0 0   $_[0]->{isize};
92             }
93              
94             sub total_out {
95 0     0 0 0   $_[0]->{osize};
96             }
97              
98             sub inflate {
99 7403     7403 0 81941   $_[0]->{input} = \$_[1];
100 7403         76820   my ($return, $status);
101 7403         79346   $_[0]->{izize} += length $_[1];
102 7403 100       78977   if (&{$_[0]->{state}}) {
  7403         101649  
103             # Finished, so flush everything
104 8         73     $return = length $_[0]->{result};
105 8         66     $status = Z_STREAM_END;
106               } else {
107 7395 50       81539     die length ($_[1]) . " input remaining" if length $_[1];
108 7395         80639     $return = length ($_[0]->{result}) - 0x8000;
109 7395 50       105527     $return = 0 if $return < 0;
110 7395         89461     $status = Z_OK;
111               }
112 7403         83932   $_[0]->{izize} -= length $_[1];
113 7403         83312   $_[0]->{osize} += $return;
114 7403 50       127934   wantarray ? (substr ($_[0]->{result}, 0, $return, ""), $status)
115                 : substr ($_[0]->{result}, 0, $return, "");
116             }
117              
118             # Public interface ends here
119              
120             sub _reset_bits_have {
121 16     16   141   my $self = shift;
122 16         184   $self->{val} = $self->{have} = 0;
123             }
124              
125              
126             # get arg bits (little endian)
127             sub _get_bits {
128 6884     6884   83686   my ($self, $want) = @_;
129 6884         72502   my ($bits_val, $bits_have) = @{$self}{qw(val have)};
  6884         78758  
130 6884         91348   while ($want > $bits_have) {
131             # inlined input read
132 3600         38604     my $byte = substr ${$_[0]->{input}}, 0, 1, "";
  3600         50862  
133 3600 100       49854     if (!length $byte) {
134 756         9001       @{$self}{qw(val have)} = ($bits_val, $bits_have);
  756         8640  
135 756         8725       return;
136                 }
137 2844         28811     $bits_val |= ord($byte) << $bits_have;
138 2844         33984     $bits_have += 8;
139               }
140 6128         67041   my $result = $bits_val & (1 << $want)-1;
141 6128         61483   $bits_val >>= $want;
142 6128         67924   $bits_have -= $want;
143 6128         68753   @{$self}{qw(val have)} = ($bits_val, $bits_have);
  6128         81680  
144 6128         80659   return $result;
145             }
146              
147             # Get one huffman code
148             sub _get_huffman {
149 12709     12709   169707   my ($self, $code) = @_;
150 12709         144468   $code = $self->{$code};
151 12709         129392   my ($bits_val, $bits_have, $str) = @{$self}{qw(val have huffman)};
  12709         170551  
152 12709         143361   do {
153 55909 100       663015       if (--$bits_have < 0) {
154             # inlined input read
155 8537         78795 my $byte = substr ${$_[0]->{input}}, 0, 1, "";
  8537         108901  
156 8537 100       134086 if (!length $byte) {
157             # bits_have is -1, but really should be zero, so fix in save
158 1789         17210 @{$self}{qw(val have huffman)} = ($bits_val, 0, $str);
  1789         23111  
159 1789         21934 return;
160             }
161 6748         71877 $bits_val = ord $byte;
162 6748         62932 $bits_have = 7;
163                   }
164 54120         623367       $str .= $bits_val & 1;
165 54120         708865       $bits_val >>= 1;
166                 } until exists $code->{$str};
167 10920 50       143473   defined($code->{$str}) || die "Bad code $str";
168 10920         117656   @{$self}{qw(val have huffman)} = ($bits_val, $bits_have, "");
  10920         158596  
169 10920         158056   return $code->{$str};
170             }
171              
172             # construct huffman code
173             sub make_huffman {
174 12     12 0 110   my $counts = shift;
175 12         99   my (%code, @counts);
176 12         145   push @{$counts[$counts->[$_]]}, $_ for 0..$#$counts;
  12         175  
  1288         34725  
177 12         114   my $value = 0;
178 12         126   my $bits = -1;
179 12         112   for (@counts) {
180 116         1018     $value *= 2;
181 116 100 100     1559     next unless ++$bits && $_;
182             # Ton used sprintf"%0${bits}b", $value;
183 76         3306     $code{reverse unpack "b$bits", pack "V", $value++} = $_ for @$_;
  76         2541  
184               }
185             # Close the code to avoid infinite loops (and out of memory)
186 12         131   $code{reverse unpack "b$bits", pack "V", $value++} = undef for
187 12         102     $value .. (1 << $bits)-1;
188 12 50       175   @code{0, 1} = () unless %code;
189 12         305   return \%code;
190             }
191              
192             # Inflate state machine.
193             {
194               my ($static_lit_code, $static_dist_code, @lit_base, @dist_base);
195              
196               my @lit_extra = (-1,
197             0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,
198             3,3,3,3,4,4,4,4,5,5,5,5,0,-2,-2);
199               my @dist_extra = (0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,
200             9,9,10,10,11,11,12,12,13,13,-1,-1);
201               my @alpha_map = (16, 17, 18, 0, 8, 7, 9, 6, 10,
202             5, 11, 4, 12, 3, 13, 2, 14, 1, 15);
203               sub prepare_tables {
204 1     1 0 11     my $length = 3;
205 1         12     for (@lit_extra) {
206 32         268       push @lit_base, $length;
207 32 100       350       $length += 1 << $_ if $_ >= 0;
208                 }
209             # Exceptional case
210 1         12     splice(@lit_base, -3, 3, 258);
211              
212 1         10     my $dist = 1;
213 1         10     for (@dist_extra) {
214 32         268       push @dist_base, $dist;
215 32 100       1277       $dist += 1 << $_ if $_ >= 0;
216                 }
217 1         14     splice(@dist_base, -2, 2);
218               }
219              
220               sub stateReadFinal {
221 8     8 0 88     my $bit = _get_bits($_[0], 1);
222 8 50       79     if (!defined $bit) {
223             # STALL
224 0         0       return;
225                 }
226 8         74     $_[0]->{final} = $bit;
227 8         68     goto &{$_[0]->{state} = \&stateReadType};
  8         104  
228               }
229               sub stateReadType {
230 8     8 0 78     my $type = _get_bits($_[0], 2);
231 8 50       79     if (!defined $type) {
232             # STALL
233 0         0       return;
234                 }
235 8         86     $_[0]->{type} = $type;
236 8 100       77     if ($type) {
237 4 100       56       prepare_tables() unless @lit_base;
238 4 50       50       if ($type == 1) {
    50          
239 0   0     0 $_[0]->{lit}  = $static_lit_code ||=
240             make_huffman([(8)x144,(9)x112, (7)x24, (8)x8]);
241 0   0     0 $_[0]->{dist} = $static_dist_code ||=
242             make_huffman([(5)x32]);
243             # This is the main inflation loop.
244 0         0 goto &{$_[0]->{state} = \&stateReadLit};
  0         0  
245                   } elsif ($type == 2) {
246 4         35 goto &{$_[0]->{state} = \&stateReadHLit};
  4         55  
247                   } else {
248 0         0 die "deflate subtype $type not supported\n";
249                   }
250                 }
251 4         33     goto &{$_[0]->{state} = \&stateReadUncompressedLen};
  4         138  
252               }
253              
254               sub stateReadUncompressedLen {
255             # Not compressed;
256 8     8 0 95     $_[0]->_reset_bits_have;
257             # inlined input read
258 8         102     $_[0]->{type0length}
259 8         72       .= substr ${$_[0]->{input}}, 0, 4 - length $_[0]->{type0length}, "";
260 8 100       88     if (length $_[0]->{type0length} < 4) {
261             # STALL
262 4         40       return;
263                 }
264 4         77     my ($len, $nlen) = unpack("vv", $_[0]->{type0length});
265 4         40     $_[0]->{type0length} = "";
266 4 50       44     $len == (~$nlen & 0xffff) ||
267                   die "$len is not the 1-complement of $nlen";
268 4         41     $_[0]->{type0left} = $len;
269 4         93     goto &{$_[0]->{state} = \&stateReadUncompressed};
  4         60  
270               }
271              
272               sub stateReadUncompressed {
273             # inlined input read
274 4850     4850 0 48006     my $got = substr ${$_[0]->{input}}, 0, $_[0]->{type0left}, "";
  4850         72029  
275 4850         64862     $_[0]->{result} .= $got;
276 4850 100       61723     if ($_[0]->{type0left} -= length $got) {
277             # Still need more.
278             # STALL
279 4846         55216       return;
280                 }
281 4 50       43     if ($_[0]->{final}) {
282             # Finished.
283 4         46       return 1;
284                 }
285             # Begin the next block
286 0         0     goto &{$_[0]->{state} = \&stateReadFinal};
  0         0  
287               }
288              
289               sub stateReadHLit {
290 4     4 0 39     my $hlit = _get_bits($_[0], 5);
291 4 50       42     if (!defined $hlit) {
292             # STALL
293 0         0       return;
294                 }
295 4         41     $_[0]->{hlit} = $hlit + 257;
296 4         33     goto &{$_[0]->{state} = \&stateReadHDist};
  4         46  
297               }
298               sub stateReadHDist {
299 5     5 0 49     my $hdist = _get_bits($_[0], 5);
300 5 100       52     if (!defined $hdist) {
301             # STALL
302 1         11       return;
303                 }
304 4         39     $_[0]->{hdist} = $hdist + 1;
305 4         35     goto &{$_[0]->{state} = \&stateReadHCLen};
  4         47  
306               }
307               sub stateReadHCLen {
308 5     5 0 45     my $hclen = _get_bits($_[0], 4);
309 5 100       53     if (!defined $hclen) {
310             # STALL
311 1         12       return;
312                 }
313 4         139     $_[0]->{alphaleft} = $_[0]->{hclen} = $hclen + 4;
314             # Determine the code length huffman code
315 4         65     $_[0]->{alpha_raw} = [(0) x @alpha_map];
316              
317 4         37     goto &{$_[0]->{state} = \&stateReadAlphaCode};
  4         51  
318               }
319               sub stateReadAlphaCode {
320 9     9 0 82     my $alpha_code = $_[0]->{alpha_raw};
321 9         94     while ($_[0]->{alphaleft}) {
322 61         622       my $code = _get_bits($_[0], 3);
323 61 100       558       if (!defined $code) {
324             # STALL
325 5         51 return;
326                   }
327             # my $where = $_[0]->{hclen} - $_[0]->{alphaleft};
328 56         657       $alpha_code->[$alpha_map[$_[0]->{hclen} - $_[0]->{alphaleft}--]] = $code;
329                 }
330 4         41     $_[0]->{alpha} = make_huffman($alpha_code);
331 4         42     delete $_[0]->{alpha_raw};
332              
333             # Get lit/length and distance tables
334 4         42     $_[0]->{code_len} = [];
335 4         36     goto &{$_[0]->{state} = \&stateBuildAlphaCode};
  4         57  
336               }
337              
338               sub stateBuildAlphaCode {
339 89     89 0 816     my $code_len = $_[0]->{code_len};
340 89         1060     while (@$code_len < $_[0]->{hlit}+$_[0]->{hdist}) {
341 565         5701       my $alpha = _get_huffman($_[0], 'alpha');
342 565 100       5388       if (!defined $alpha) {
343             # STALL
344 57         582 return;
345                   }
346 508 100       50187       if ($alpha < 16) {
    100          
    100          
347 480         6646 push @$code_len, $alpha;
348                   } elsif ($alpha == 16) {
349 4         35 goto &{$_[0]->{state} = \&stateReadAlphaCode16};
  4         58  
350                   } elsif ($alpha == 17) {
351 16         132 goto &{$_[0]->{state} = \&stateReadAlphaCode17};
  16         214  
352                   } else {
353 8         151 goto &{$_[0]->{state} = \&stateReadAlphaCodeOther};
  8         177  
354                   }
355                 }
356 4 50       52     @$code_len == $_[0]->{hlit}+$_[0]->{hdist} || die "too many codes";
357 4         1675     my @lit_len = splice(@$code_len, 0, $_[0]->{hlit});
358 4         124     $_[0]->{lit} = make_huffman(\@lit_len);
359 4         48     $_[0]->{dist} = make_huffman($code_len);
360 4         47     delete $_[0]->{code_len};
361 4         34     goto &{$_[0]->{state} = \&stateReadLit};
  4         105  
362               }
363              
364               sub stateReadAlphaCode16 {
365 5     5 0 51     my $code_len = $_[0]->{code_len};
366 5         51     my $bits = _get_bits($_[0], 2);
367 5 100       51     if (!defined $bits) {
368             # STALL
369 1         11       return;
370                 }
371 4         46     push @$code_len, ($code_len->[-1]) x (3+$bits);
372 4         34     goto &{$_[0]->{state} = \&stateBuildAlphaCode};
  4         46  
373               }
374              
375               sub stateReadAlphaCode17 {
376 19     19 0 262     my $code_len = $_[0]->{code_len};
377 19         183     my $bits = _get_bits($_[0], 3);
378 19 100       205     if (!defined $bits) {
379             # STALL
380 3         31       return;
381                 }
382 16         206     push @$code_len, (0) x (3+$bits);
383 16         129     goto &{$_[0]->{state} = \&stateBuildAlphaCode};
  16         248  
384               }
385              
386               sub stateReadAlphaCodeOther {
387 10     10 0 94     my $code_len = $_[0]->{code_len};
388 10         97     my $bits = _get_bits($_[0], 7);
389 10 100       98     if (!defined $bits) {
390             # STALL
391 2         21       return;
392                 }
393 8         176     push @$code_len, (0) x (11+$bits);
394 8         66     goto &{$_[0]->{state} = \&stateBuildAlphaCode};
  8         93  
395               }
396              
397               sub stateReadLit {
398 4318     4318 0 41614     while (1) {
399 8710         94263       my $lit = _get_huffman($_[0], 'lit');
400 8710 100       148973       if (!defined $lit) {
401             # STALL
402 1306         13851 return;
403                   }
404 7404 100       87693     if ($lit >= 256) {
405 3012 100       38432       if ($lit_extra[$lit -= 256] < 0) {
406 4 50       42 die "Invalid literal code" if $lit;
407              
408 4 50       44 if ($_[0]->{final}) {
409             # Finished.
410 4         42 return 1;
411             }
412             # Begin the next block
413 0         0 goto &{$_[0]->{state} = \&stateReadFinal};
  0         0  
414                   }
415 3008         30831       $_[0]->{litcode} = $lit;
416             # BREAK
417 3008         30119       goto &{$_[0]->{state} = \&stateGetLength};
  3008         45716  
418                 }
419              
420 4392         118279       $_[0]->{result} .= chr $lit;
421             # Back to the main inflation loop
422             # goto &stateReadLit;
423             # ie loop
424                 }
425               }
426              
427               sub stateGetLength {
428 3030     3030 0 32825     my $lit = $_[0]->{litcode};
429 3030         40248     my $bits = _get_bits($_[0], $lit_extra[$lit]);
430 3030 100       45189     if (!defined $bits) {
431             # STALL
432 22         242       return;
433                 }
434 3008   100     48990     $_[0]->{length} = $lit_base[$lit] + ($lit_extra[$lit] && $bits);
435 3008         32413     goto &{$_[0]->{state} = \&stateGetDCode};
  3008         47765  
436               }
437              
438               sub stateGetDCode {
439 3434     3434 0 38981     my $d = _get_huffman($_[0], 'dist');
440 3434 100       40348     if (!defined $d) {
441             # STALL
442 426         4461       return;
443                 }
444 3008         35319     $_[0]->{dcode} = $d;
445 3008         28945     goto &{$_[0]->{state} = \&stateGetDistDecompress};
  3008         42452  
446               }
447              
448               sub stateGetDistDecompress {
449 3729     3729 0 40725     my $d = $_[0]->{dcode};
450 3729 50       45994     die "Invalid distance code" if $d >= 30;
451 3729         83287     my $bits = _get_bits($_[0], $dist_extra[$d]);
452 3729 100       40915     if (!defined $bits) {
453             # STALL
454 721         9590       return;
455                 }
456 3008   100     48414     my $dist = $dist_base[$d] + ($dist_extra[$d] && $bits);
457              
458             # Go for it
459 3008         34096     my $length = $_[0]->{length};
460 3008 100       30964     if ($dist >= $length) {
461 3004         51321       my $section = substr ($_[0]->{result}, -$dist, $length);
462 3004         35266       $_[0]->{result} .= $section;
463                 } else {
464 4         35       my $remaining = $length;
465 4         40       while ($remaining) {
466 12 100       105 my $take
467             = $dist >= $remaining ? $remaining : $dist;
468 12         185 $_[0]->{result} .= substr($_[0]->{result}, -$dist, $take);
469 12         115 $remaining -= $take;
470                   }
471                 }
472             # Back to the main inflation loop
473 3008         35817     goto &{$_[0]->{state} = \&stateReadLit};
  3008         43082  
474               }
475             }
476              
477             1;
478             __END__
479            
480             =head1 NAME
481            
482             Compress::Zlib::Perl - (Partial) Pure perl implementation of Compress::Zlib
483            
484             =head1 SYNOPSIS
485            
486             use Compress::Zlib::Perl;
487             ($i, $status) = inflateInit(-WindowBits => -MAX_WBITS);
488             ($out, $status) = $i->inflate($buffer);
489            
490             =head1 DESCRIPTION
491            
492             This a pure perl implementation of Compress::Zlib's inflate API.
493            
494             =head2 Inflating deflated data
495            
496             Currently the only thing Compress::Zlib::Perl can do is inflate compressed
497             data. A constructor and 3 methods from Compress::Zlib's interface are
498             replicated:
499            
500             =over 4
501            
502             =item inflateInit -WindowBits => -MAX_WBITS
503            
504             Argument list specifies options. Expects that the option -WindowBits is set
505             to a negative value. In scalar context returns an C<inflater> object; in list
506             context returns this object and a status (usually C<Z_OK>)
507            
508             =item inflate INPUT
509            
510             Inflates this section of deflate compressed data stream. In scalar context
511             returns some inflated data; in list context returns this data and an output
512             status. The status is C<Z_OK> if the input stream is not yet finished,
513             C<Z_STREAM_END> if all the input data is consumed and this output is the
514             final output.
515            
516             C<inflate> modifies the input parameter; at the end of the compressed stream
517             any data beyond its end remains in I<INPUT>. Before the end of stream all
518             input data is consumed during the C<inflate> call.
519            
520             This implementation of C<inflate> may not be as prompt at returning data as
521             Compress::Zlib's; this implementation currently buffers the last 32768 bytes
522             of output data until the end of the input stream, rather than attempting to
523             return as much data as possible during inflation.
524            
525             =item total_in
526            
527             Returns the total input (compressed) data so far
528            
529             =item total_out
530            
531             Returns the total output (uncompressed) data so far
532            
533             =back
534            
535             =head2 EXPORT
536            
537             =over 4
538            
539             =item crc32 BUFFER[, CRC32]
540            
541             Calculate and return a 32 bit checksum for buffer. CRC32 is suitably
542             initialised if C<undef> is passed in.
543            
544             =item Z_OK
545            
546             Constant for returning normal status
547            
548             =item Z_STREAM_END
549            
550             Constant for returning end of stream
551            
552             =item MAX_WBITS
553            
554             Constant to pass to inflateInit (for compatibility with Compress::Zlib)
555            
556             =back
557            
558             =head1 TODO
559            
560             =over
561            
562             =item *
563            
564             Test and if necessary fix on big endian systems
565            
566             =item *
567            
568             Backport to at least 5.005_03
569            
570             =item *
571            
572             Fill in all the other missing Comress::Zlib APIs
573            
574             =back
575            
576             =head1 BUGS
577            
578             =over 4
579            
580             =item *
581            
582             Doesn't implement all of Compress::Zlib
583            
584             =item *
585            
586             Doesn't emulate Compress::Zlib's error return values - instead uses C<die>
587            
588             =item *
589            
590             Slow. Well, what did you expect?
591            
592             =back
593            
594             =head1 SEE ALSO
595            
596             Compress::Zlib
597            
598             =head1 AUTHOR
599            
600             Ton Hospel wrote a pure perl gunzip program.
601             Nicholas Clark, E<lt>nick@talking.bollo.cx<gt> turned it into a state machine
602             and reworked the decompression core to fit Compress::Zlib's interface.
603            
604             =head1 COPYRIGHT AND LICENSE
605            
606             Copyright 2004 by Ton Hospel, Nicholas Clark
607            
608             This library is free software; you can redistribute it and/or modify
609             it under the same terms as Perl itself.
610            
611             =cut
612