Commit | Line | Data |
16816334 |
1 | BEGIN { |
d695c1a1 |
2 | if ($ENV{PERL_CORE}) { |
16816334 |
3 | chdir 't' if -d 't'; |
4 | @INC = '../lib'; |
5 | } |
6 | } |
642e522c |
7 | |
8 | use lib 't'; |
9 | use strict; |
10 | use warnings; |
11 | use bytes; |
12 | |
13 | use Test::More ; |
14 | use ZlibTestUtils; |
15 | |
16 | BEGIN { |
17 | # use Test::NoWarnings, if available |
18 | my $extra = 0 ; |
19 | $extra = 1 |
20 | if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; |
21 | |
22 | plan tests => 595 + $extra ; |
23 | |
24 | use_ok('Compress::Zlib', 2) ; |
25 | |
26 | use_ok('IO::Compress::Deflate', qw($DeflateError)) ; |
27 | use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; |
28 | |
29 | use_ok('Compress::Zlib::FileConstants'); |
30 | |
31 | } |
32 | |
33 | |
34 | sub ReadHeaderInfo |
35 | { |
36 | my $string = shift || '' ; |
37 | my %opts = @_ ; |
38 | |
39 | my $buffer ; |
40 | ok my $def = new IO::Compress::Deflate \$buffer, %opts ; |
41 | is $def->write($string), length($string) ; |
42 | ok $def->close ; |
43 | #print "ReadHeaderInfo\n"; hexDump(\$buffer); |
44 | |
45 | ok my $inf = new IO::Uncompress::Inflate \$buffer ; |
46 | my $uncomp ; |
47 | #ok $inf->read($uncomp) ; |
48 | my $actual = 0 ; |
49 | my $status = 1 ; |
50 | while (($status = $inf->read($uncomp)) > 0) { |
51 | $actual += $status ; |
52 | } |
53 | |
54 | is $actual, length($string) ; |
55 | is $uncomp, $string; |
56 | ok ! $inf->error() ; |
57 | ok $inf->eof() ; |
58 | ok my $hdr = $inf->getHeaderInfo(); |
59 | ok $inf->close ; |
60 | |
61 | return $hdr ; |
62 | } |
63 | |
64 | sub ReadHeaderInfoZlib |
65 | { |
66 | my $string = shift || '' ; |
67 | my %opts = @_ ; |
68 | |
69 | my $buffer ; |
70 | ok my $def = new Compress::Zlib::Deflate AppendOutput => 1, %opts ; |
71 | cmp_ok $def->deflate($string, $buffer), '==', Z_OK; |
72 | cmp_ok $def->flush($buffer), '==', Z_OK; |
73 | #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer); |
74 | |
75 | ok my $inf = new IO::Uncompress::Inflate \$buffer ; |
76 | my $uncomp ; |
77 | #ok $inf->read($uncomp) ; |
78 | my $actual = 0 ; |
79 | my $status = 1 ; |
80 | while (($status = $inf->read($uncomp)) > 0) { |
81 | $actual += $status ; |
82 | } |
83 | |
84 | is $actual, length($string) ; |
85 | is $uncomp, $string; |
86 | ok ! $inf->error() ; |
87 | ok $inf->eof() ; |
88 | ok my $hdr = $inf->getHeaderInfo(); |
89 | ok $inf->close ; |
90 | |
91 | return $hdr ; |
92 | } |
93 | |
94 | sub printHeaderInfo |
95 | { |
96 | my $buffer = shift ; |
97 | my $inf = new IO::Uncompress::Inflate \$buffer ; |
98 | my $hdr = $inf->getHeaderInfo(); |
99 | |
100 | no warnings 'uninitialized' ; |
101 | while (my ($k, $v) = each %$hdr) { |
102 | print " $k -> $v\n" ; |
103 | } |
104 | } |
105 | |
106 | |
107 | # Check the Deflate Header Parameters |
108 | #======================================== |
109 | |
110 | my $name = "test.gz" ; |
111 | my $lex = new LexFile $name ; |
112 | |
113 | { |
114 | title "Check default header settings" ; |
115 | |
116 | my $string = <<EOM; |
117 | some text |
118 | EOM |
119 | |
120 | my $hdr = ReadHeaderInfo($string); |
121 | |
122 | is $hdr->{CM}, 8, " CM is 8"; |
123 | is $hdr->{FDICT}, 0, " FDICT is 0"; |
124 | |
125 | } |
126 | |
127 | { |
128 | title "Check user-defined header settings match zlib" ; |
129 | |
130 | my $string = <<EOM; |
131 | some text |
132 | EOM |
133 | |
134 | my @tests = ( |
135 | [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
136 | [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
137 | [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
138 | [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
139 | [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
140 | [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
141 | [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], |
142 | [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
143 | [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
144 | [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
145 | |
146 | [ {-Level => Z_NO_COMPRESSION }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
147 | [ {-Level => Z_BEST_SPEED }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
148 | [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
149 | [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], |
150 | |
151 | [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
152 | [ {-Strategy => Z_HUFFMAN_ONLY, |
153 | -Level => 3 }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
154 | ); |
155 | |
156 | foreach my $test (@tests) |
157 | { |
158 | my $opts = $test->[0] ; |
159 | my $expect = $test->[1] ; |
160 | |
161 | my @title ; |
162 | while (my ($k, $v) = each %$opts) |
163 | { |
164 | push @title, "$k => $v"; |
165 | } |
166 | title " Set @title"; |
167 | |
168 | my $hdr = ReadHeaderInfo($string, %$opts); |
169 | |
170 | my $hdr1 = ReadHeaderInfoZlib($string, %$opts); |
171 | |
172 | is $hdr->{CM}, 8, " CM is 8"; |
173 | is $hdr->{CINFO}, 7, " CINFO is 7"; |
174 | is $hdr->{FDICT}, 0, " FDICT is 0"; |
175 | |
176 | while (my ($k, $v) = each %$expect) |
177 | { |
178 | if (ZLIB_VERNUM >= 0x1220) |
179 | { is $hdr->{$k}, $v, " $k is $v" } |
180 | else |
181 | { ok 1, " Skip test for $k" } |
182 | } |
183 | |
184 | is $hdr->{CM}, $hdr1->{CM}, " CM matches"; |
185 | is $hdr->{CINFO}, $hdr1->{CINFO}, " CINFO matches"; |
186 | is $hdr->{FDICT}, $hdr1->{FDICT}, " FDICT matches"; |
187 | is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, " FLEVEL matches"; |
188 | is $hdr->{FCHECK}, $hdr1->{FCHECK}, " FCHECK matches"; |
189 | } |
190 | |
191 | |
192 | } |
193 | |
194 | { |
195 | title "No compressed data at all"; |
196 | |
197 | my $hdr = ReadHeaderInfo(""); |
198 | |
199 | is $hdr->{CM}, 8, " CM is 8"; |
200 | is $hdr->{FDICT}, 0, " FDICT is 0"; |
201 | |
202 | ok defined $hdr->{ADLER32}, " ADLER32 is defined" ; |
203 | is $hdr->{ADLER32}, 1, " ADLER32 is 1"; |
204 | } |
205 | |
206 | { |
207 | # Header Corruption Tests |
208 | |
209 | my $string = <<EOM; |
210 | some text |
211 | EOM |
212 | |
213 | my $good ; |
214 | ok my $x = new IO::Compress::Deflate \$good ; |
215 | ok $x->write($string) ; |
216 | ok $x->close ; |
217 | |
218 | { |
219 | title "Header Corruption - FCHECK failure - 1st byte wrong"; |
220 | my $buffer = $good ; |
221 | substr($buffer, 0, 1) = "\x00" ; |
222 | |
223 | ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
224 | like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', |
225 | "CRC mismatch"; |
226 | } |
227 | |
228 | { |
229 | title "Header Corruption - FCHECK failure - 2nd byte wrong"; |
230 | my $buffer = $good ; |
231 | substr($buffer, 1, 1) = "\x00" ; |
232 | |
233 | ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
234 | like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', |
235 | "CRC mismatch"; |
236 | } |
237 | |
238 | |
239 | sub mkZlibHdr |
240 | { |
241 | my $method = shift ; |
242 | my $cinfo = shift ; |
243 | my $fdict = shift ; |
244 | my $level = shift ; |
245 | |
246 | my $cmf = ($method & 0x0F) ; |
247 | $cmf |= (($cinfo & 0x0F) << 4) ; |
248 | my $flg = (($level & 0x03) << 6) ; |
249 | $flg |= (($fdict & 0x01) << 5) ; |
250 | my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; |
251 | $flg |= $fcheck ; |
252 | #print "check $fcheck\n"; |
253 | |
254 | return pack("CC", $cmf, $flg) ; |
255 | } |
256 | |
257 | { |
258 | title "Header Corruption - CM not 8"; |
259 | my $buffer = $good ; |
260 | my $header = mkZlibHdr(3, 6, 0, 3); |
261 | |
262 | substr($buffer, 0, 2) = $header; |
263 | |
264 | my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
265 | ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
266 | like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/', |
267 | " Not Deflate"; |
268 | } |
269 | |
270 | } |
271 | |
272 | { |
273 | # Trailer Corruption tests |
274 | |
275 | my $string = <<EOM; |
276 | some text |
277 | EOM |
278 | |
279 | my $good ; |
280 | ok my $x = new IO::Compress::Deflate \$good ; |
281 | ok $x->write($string) ; |
282 | ok $x->close ; |
283 | |
284 | foreach my $trim (-4 .. -1) |
285 | { |
286 | my $got = $trim + 4 ; |
287 | foreach my $s (0, 1) |
288 | { |
289 | title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ; |
290 | my $buffer = $good ; |
291 | my $expected_trailing = substr($good, -4, 4) ; |
292 | substr($expected_trailing, $trim) = ''; |
293 | |
294 | substr($buffer, $trim) = ''; |
295 | writeFile($name, $buffer) ; |
296 | |
297 | ok my $gunz = new IO::Uncompress::Inflate $name, Strict => $s; |
298 | my $uncomp ; |
299 | if ($s) |
300 | { |
301 | ok $gunz->read($uncomp) < 0 ; |
302 | like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/", |
303 | "Trailer Error"; |
304 | } |
305 | else |
306 | { |
307 | is $gunz->read($uncomp), length $string ; |
308 | } |
309 | ok $gunz->eof() ; |
310 | ok $uncomp eq $string; |
311 | ok $gunz->close ; |
312 | } |
313 | |
314 | } |
315 | |
316 | { |
317 | title "Trailer Corruption - CRC Wrong, strict" ; |
318 | my $buffer = $good ; |
319 | my $crc = unpack("N", substr($buffer, -4, 4)); |
320 | substr($buffer, -4, 4) = pack('N', $crc+1); |
321 | writeFile($name, $buffer) ; |
322 | |
323 | ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 1; |
324 | my $uncomp ; |
325 | ok $gunz->read($uncomp) < 0 ; |
326 | like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/', |
327 | "Trailer Error: CRC mismatch"; |
328 | ok $gunz->eof() ; |
329 | ok ! ${ $gunz->trailingData() } ; |
330 | ok $uncomp eq $string; |
331 | ok $gunz->close ; |
332 | } |
333 | |
334 | { |
335 | title "Trailer Corruption - CRC Wrong, no strict" ; |
336 | my $buffer = $good ; |
337 | my $crc = unpack("N", substr($buffer, -4, 4)); |
338 | substr($buffer, -4, 4) = pack('N', $crc+1); |
339 | writeFile($name, $buffer) ; |
340 | |
341 | ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 0; |
342 | my $uncomp ; |
343 | ok $gunz->read($uncomp) >= 0 ; |
344 | ok $gunz->eof() ; |
345 | ok ! ${ $gunz->trailingData() } ; |
346 | ok $uncomp eq $string; |
347 | ok $gunz->close ; |
348 | } |
349 | } |
350 | |