| Commit | Line | Data |
|---|
| 25f0751f |
1 | BEGIN { |
| 2 | if ($ENV{PERL_CORE}) { |
| 3 | chdir 't' if -d 't'; |
| 4 | @INC = ("../lib", "lib/compress"); |
| 5 | } |
| 6 | } |
| 7 | |
| 8 | use lib qw(t t/compress); |
| 9 | use strict; |
| 10 | use warnings; |
| 11 | use bytes; |
| 12 | |
| 13 | use Test::More ; |
| 14 | use CompTestUtils; |
| 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::Raw::Zlib') ; |
| 25 | |
| 26 | use_ok('IO::Compress::Deflate', qw($DeflateError)) ; |
| 27 | use_ok('IO::Uncompress::Inflate', qw($InflateError)) ; |
| 28 | |
| 29 | use_ok('IO::Compress::Zlib::Constants'); |
| 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 | |
| 93d092e2 |
45 | ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1 ; |
| 25f0751f |
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::Raw::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 | |
| 93d092e2 |
75 | ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1 ; |
| 25f0751f |
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 $lex = new LexFile my $name ; |
| 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 | |
projects / p5sagit/p5-mst-13.2.git / blame