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