Commit | Line | Data |
16816334 |
1 | BEGIN { |
d695c1a1 |
2 | if ($ENV{PERL_CORE}) { |
16816334 |
3 | chdir 't' if -d 't'; |
0ecadccd |
4 | @INC = ("../lib", "lib"); |
16816334 |
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 | |
9f2e3514 |
110 | my $lex = new LexFile my $name ; |
642e522c |
111 | |
112 | { |
113 | title "Check default header settings" ; |
114 | |
115 | my $string = <<EOM; |
116 | some text |
117 | EOM |
118 | |
119 | my $hdr = ReadHeaderInfo($string); |
120 | |
121 | is $hdr->{CM}, 8, " CM is 8"; |
122 | is $hdr->{FDICT}, 0, " FDICT is 0"; |
123 | |
124 | } |
125 | |
126 | { |
127 | title "Check user-defined header settings match zlib" ; |
128 | |
129 | my $string = <<EOM; |
130 | some text |
131 | EOM |
132 | |
133 | my @tests = ( |
134 | [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
135 | [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
136 | [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
137 | [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
138 | [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
139 | [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST } ], |
140 | [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], |
141 | [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
142 | [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
143 | [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
144 | |
145 | [ {-Level => Z_NO_COMPRESSION }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
146 | [ {-Level => Z_BEST_SPEED }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
147 | [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ], |
148 | [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ], |
149 | |
150 | [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
151 | [ {-Strategy => Z_HUFFMAN_ONLY, |
152 | -Level => 3 }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ], |
153 | ); |
154 | |
155 | foreach my $test (@tests) |
156 | { |
157 | my $opts = $test->[0] ; |
158 | my $expect = $test->[1] ; |
159 | |
160 | my @title ; |
161 | while (my ($k, $v) = each %$opts) |
162 | { |
163 | push @title, "$k => $v"; |
164 | } |
165 | title " Set @title"; |
166 | |
167 | my $hdr = ReadHeaderInfo($string, %$opts); |
168 | |
169 | my $hdr1 = ReadHeaderInfoZlib($string, %$opts); |
170 | |
171 | is $hdr->{CM}, 8, " CM is 8"; |
172 | is $hdr->{CINFO}, 7, " CINFO is 7"; |
173 | is $hdr->{FDICT}, 0, " FDICT is 0"; |
174 | |
175 | while (my ($k, $v) = each %$expect) |
176 | { |
177 | if (ZLIB_VERNUM >= 0x1220) |
178 | { is $hdr->{$k}, $v, " $k is $v" } |
179 | else |
180 | { ok 1, " Skip test for $k" } |
181 | } |
182 | |
183 | is $hdr->{CM}, $hdr1->{CM}, " CM matches"; |
184 | is $hdr->{CINFO}, $hdr1->{CINFO}, " CINFO matches"; |
185 | is $hdr->{FDICT}, $hdr1->{FDICT}, " FDICT matches"; |
186 | is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, " FLEVEL matches"; |
187 | is $hdr->{FCHECK}, $hdr1->{FCHECK}, " FCHECK matches"; |
188 | } |
189 | |
190 | |
191 | } |
192 | |
193 | { |
194 | title "No compressed data at all"; |
195 | |
196 | my $hdr = ReadHeaderInfo(""); |
197 | |
198 | is $hdr->{CM}, 8, " CM is 8"; |
199 | is $hdr->{FDICT}, 0, " FDICT is 0"; |
200 | |
201 | ok defined $hdr->{ADLER32}, " ADLER32 is defined" ; |
202 | is $hdr->{ADLER32}, 1, " ADLER32 is 1"; |
203 | } |
204 | |
205 | { |
206 | # Header Corruption Tests |
207 | |
208 | my $string = <<EOM; |
209 | some text |
210 | EOM |
211 | |
212 | my $good ; |
213 | ok my $x = new IO::Compress::Deflate \$good ; |
214 | ok $x->write($string) ; |
215 | ok $x->close ; |
216 | |
217 | { |
218 | title "Header Corruption - FCHECK failure - 1st byte wrong"; |
219 | my $buffer = $good ; |
220 | substr($buffer, 0, 1) = "\x00" ; |
221 | |
222 | ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
223 | like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', |
224 | "CRC mismatch"; |
225 | } |
226 | |
227 | { |
228 | title "Header Corruption - FCHECK failure - 2nd byte wrong"; |
229 | my $buffer = $good ; |
230 | substr($buffer, 1, 1) = "\x00" ; |
231 | |
232 | ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
233 | like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', |
234 | "CRC mismatch"; |
235 | } |
236 | |
237 | |
238 | sub mkZlibHdr |
239 | { |
240 | my $method = shift ; |
241 | my $cinfo = shift ; |
242 | my $fdict = shift ; |
243 | my $level = shift ; |
244 | |
245 | my $cmf = ($method & 0x0F) ; |
246 | $cmf |= (($cinfo & 0x0F) << 4) ; |
247 | my $flg = (($level & 0x03) << 6) ; |
248 | $flg |= (($fdict & 0x01) << 5) ; |
249 | my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; |
250 | $flg |= $fcheck ; |
251 | #print "check $fcheck\n"; |
252 | |
253 | return pack("CC", $cmf, $flg) ; |
254 | } |
255 | |
256 | { |
257 | title "Header Corruption - CM not 8"; |
258 | my $buffer = $good ; |
259 | my $header = mkZlibHdr(3, 6, 0, 3); |
260 | |
261 | substr($buffer, 0, 2) = $header; |
262 | |
263 | my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
264 | ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0 ; |
265 | like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/', |
266 | " Not Deflate"; |
267 | } |
268 | |
269 | } |
270 | |
271 | { |
272 | # Trailer Corruption tests |
273 | |
274 | my $string = <<EOM; |
275 | some text |
276 | EOM |
277 | |
278 | my $good ; |
279 | ok my $x = new IO::Compress::Deflate \$good ; |
280 | ok $x->write($string) ; |
281 | ok $x->close ; |
282 | |
283 | foreach my $trim (-4 .. -1) |
284 | { |
285 | my $got = $trim + 4 ; |
286 | foreach my $s (0, 1) |
287 | { |
288 | title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ; |
289 | my $buffer = $good ; |
290 | my $expected_trailing = substr($good, -4, 4) ; |
291 | substr($expected_trailing, $trim) = ''; |
292 | |
293 | substr($buffer, $trim) = ''; |
294 | writeFile($name, $buffer) ; |
295 | |
296 | ok my $gunz = new IO::Uncompress::Inflate $name, Strict => $s; |
297 | my $uncomp ; |
298 | if ($s) |
299 | { |
300 | ok $gunz->read($uncomp) < 0 ; |
301 | like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/", |
302 | "Trailer Error"; |
303 | } |
304 | else |
305 | { |
306 | is $gunz->read($uncomp), length $string ; |
307 | } |
308 | ok $gunz->eof() ; |
309 | ok $uncomp eq $string; |
310 | ok $gunz->close ; |
311 | } |
312 | |
313 | } |
314 | |
315 | { |
316 | title "Trailer Corruption - CRC Wrong, strict" ; |
317 | my $buffer = $good ; |
318 | my $crc = unpack("N", substr($buffer, -4, 4)); |
319 | substr($buffer, -4, 4) = pack('N', $crc+1); |
320 | writeFile($name, $buffer) ; |
321 | |
322 | ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 1; |
323 | my $uncomp ; |
324 | ok $gunz->read($uncomp) < 0 ; |
325 | like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/', |
326 | "Trailer Error: CRC mismatch"; |
327 | ok $gunz->eof() ; |
328 | ok ! ${ $gunz->trailingData() } ; |
329 | ok $uncomp eq $string; |
330 | ok $gunz->close ; |
331 | } |
332 | |
333 | { |
334 | title "Trailer Corruption - CRC Wrong, no strict" ; |
335 | my $buffer = $good ; |
336 | my $crc = unpack("N", substr($buffer, -4, 4)); |
337 | substr($buffer, -4, 4) = pack('N', $crc+1); |
338 | writeFile($name, $buffer) ; |
339 | |
340 | ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 0; |
341 | my $uncomp ; |
342 | ok $gunz->read($uncomp) >= 0 ; |
343 | ok $gunz->eof() ; |
344 | ok ! ${ $gunz->trailingData() } ; |
345 | ok $uncomp eq $string; |
346 | ok $gunz->close ; |
347 | } |
348 | } |
349 | |