1BEGIN { 2 if ($ENV{PERL_CORE}) { 3 chdir 't' if -d 't'; 4 @INC = ("../lib", "lib/compress"); 5 } 6} 7 8use lib qw(t t/compress); 9use strict; 10use warnings; 11use bytes; 12 13use Test::More ; 14use CompTestUtils; 15 16BEGIN { 17 # use Test::NoWarnings, if available 18 my $extra = 0 ; 19 $extra = 1 20 if eval { require Test::NoWarnings ; Test::NoWarnings->import; 1 }; 21 22 plan tests => 114 + $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 34sub ReadHeaderInfo 35{ 36 my $string = shift || '' ; 37 my %opts = @_ ; 38 39 my $buffer ; 40 ok my $def = IO::Compress::Deflate->new( \$buffer, %opts ); 41 is $def->write($string), length($string), "write" ; 42 ok $def->close, "closed" ; 43 #print "ReadHeaderInfo\n"; hexDump(\$buffer); 44 45 ok my $inf = IO::Uncompress::Inflate->new( \$buffer, Append => 1 ); 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(), "! error" ; 57 ok $inf->eof(), "eof" ; 58 ok my $hdr = $inf->getHeaderInfo(); 59 ok $inf->close ; 60 61 return $hdr ; 62} 63 64sub ReadHeaderInfoZlib 65{ 66 my $string = shift || '' ; 67 my %opts = @_ ; 68 69 my $buffer ; 70 ok my $def = Compress::Raw::Zlib::Deflate->new( 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 = IO::Uncompress::Inflate->new( \$buffer, Append => 1 ); 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 94sub printHeaderInfo 95{ 96 my $buffer = shift ; 97 my $inf = IO::Uncompress::Inflate->new( \$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 = LexFile->new( my $name ); 111 112{ 113 title "Check default header settings" ; 114 115 my $string = <<EOM; 116some text 117EOM 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 126if (0) # disable these tests: IO::Compress::Deflate doesn't create the zlib header itself so no need to test 127{ 128 title "Check user-defined header settings match zlib" ; 129 130 my $string = <<EOM; 131some text 132EOM 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 # zlib-ng <= 2.0.6 with Level 1 sets the CINFO value to 5 . All other zlib & zlib-ng use expected value of 7 173 # Note that zlib-ng 2.0.x uses a 16-bit encoding for ZLIBNG_VERNUM 174 my $cinfoValue = Compress::Raw::Zlib::is_zlibng() && Compress::Raw::Zlib::ZLIBNG_VERNUM() <= 0x2060 && defined $opts->{'-Level'} && $opts->{'-Level'} == 1 ? 5 : 7; 175 is $hdr->{CM}, 8, " CM is 8"; 176 is $hdr->{CINFO}, $cinfoValue, " CINFO is $cinfoValue"; 177 is $hdr->{FDICT}, 0, " FDICT is 0"; 178 179 while (my ($k, $v) = each %$expect) 180 { 181 if (Compress::Raw::Zlib::is_zlibng() || ZLIB_VERNUM >= 0x1220) 182 { is $hdr->{$k}, $v, " $k is $v" } 183 else 184 { ok 1, " Skip test for $k" } 185 } 186 187 is $hdr->{CM}, $hdr1->{CM}, " CM matches"; 188 is $hdr->{CINFO}, $hdr1->{CINFO}, " CINFO matches"; 189 is $hdr->{FDICT}, $hdr1->{FDICT}, " FDICT matches"; 190 is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, " FLEVEL matches"; 191 is $hdr->{FCHECK}, $hdr1->{FCHECK}, " FCHECK matches"; 192 } 193 194 195} 196 197{ 198 title "No compressed data at all"; 199 200 my $hdr = ReadHeaderInfo(""); 201 202 is $hdr->{CM}, 8, " CM is 8"; 203 is $hdr->{FDICT}, 0, " FDICT is 0"; 204 205 ok defined $hdr->{ADLER32}, " ADLER32 is defined" ; 206 is $hdr->{ADLER32}, 1, " ADLER32 is 1"; 207} 208 209{ 210 # Header Corruption Tests 211 212 my $string = <<EOM; 213some text 214EOM 215 216 my $good ; 217 ok my $x = IO::Compress::Deflate->new( \$good ); 218 ok $x->write($string) ; 219 ok $x->close ; 220 221 { 222 title "Header Corruption - FCHECK failure - 1st byte wrong"; 223 my $buffer = $good ; 224 substr($buffer, 0, 1) = "\x00" ; 225 226 ok ! IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); 227 like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', 228 "CRC mismatch"; 229 } 230 231 { 232 title "Header Corruption - FCHECK failure - 2nd byte wrong"; 233 my $buffer = $good ; 234 substr($buffer, 1, 1) = "\x00" ; 235 236 ok ! IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); 237 like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/', 238 "CRC mismatch"; 239 } 240 241 242 sub mkZlibHdr 243 { 244 my $method = shift ; 245 my $cinfo = shift ; 246 my $fdict = shift ; 247 my $level = shift ; 248 249 my $cmf = ($method & 0x0F) ; 250 $cmf |= (($cinfo & 0x0F) << 4) ; 251 my $flg = (($level & 0x03) << 6) ; 252 $flg |= (($fdict & 0x01) << 5) ; 253 my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ; 254 $flg |= $fcheck ; 255 #print "check $fcheck\n"; 256 257 return pack("CC", $cmf, $flg) ; 258 } 259 260 { 261 title "Header Corruption - CM not 8"; 262 my $buffer = $good ; 263 my $header = mkZlibHdr(3, 6, 0, 3); 264 265 substr($buffer, 0, 2) = $header; 266 267 my $un = IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); 268 ok ! IO::Uncompress::Inflate->new( \$buffer, -Transparent => 0 ); 269 like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/', 270 " Not Deflate"; 271 } 272 273} 274 275{ 276 # Trailer Corruption tests 277 278 my $string = <<EOM; 279some text 280EOM 281 282 $string = $string x 1000; 283 my $good ; 284 ok my $x = IO::Compress::Deflate->new( \$good ); 285 ok $x->write($string) ; 286 ok $x->close ; 287 288 foreach my $trim (-4 .. -1) 289 { 290 my $got = $trim + 4 ; 291 foreach my $s (0, 1) 292 { 293 title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ; 294 my $lex = LexFile->new( my $name ); 295 my $buffer = $good ; 296 my $expected_trailing = substr($good, -4, 4) ; 297 substr($expected_trailing, $trim) = ''; 298 299 substr($buffer, $trim) = ''; 300 writeFile($name, $buffer) ; 301 302 ok my $gunz = IO::Uncompress::Inflate->new( $name, Append => 1, Strict => $s ); 303 my $uncomp ; 304 if ($s) 305 { 306 my $status ; 307 1 while ($status = $gunz->read($uncomp)) > 0; 308 cmp_ok $status, "<", 0 ; 309 like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/", 310 "Trailer Error"; 311 } 312 else 313 { 314 1 while $gunz->read($uncomp) > 0; 315 is $uncomp, $string ; 316 } 317 ok $gunz->eof() ; 318 ok $uncomp eq $string; 319 ok $gunz->close ; 320 } 321 322 } 323 324 { 325 title "Trailer Corruption - CRC Wrong, strict" ; 326 my $buffer = $good ; 327 my $crc = unpack("N", substr($buffer, -4, 4)); 328 substr($buffer, -4, 4) = pack('N', $crc+1); 329 my $lex = LexFile->new( my $name ); 330 writeFile($name, $buffer) ; 331 332 ok my $gunz = IO::Uncompress::Inflate->new( $name, Append => 1, Strict => 1 ); 333 my $uncomp ; 334 my $status ; 335 1 while ($status = $gunz->read($uncomp)) > 0; 336 cmp_ok $status, "<", 0 ; 337 like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/', 338 "Trailer Error: CRC mismatch"; 339 ok $gunz->eof() ; 340 ok ! $gunz->trailingData() ; 341 ok $uncomp eq $string; 342 ok $gunz->close ; 343 } 344 345 { 346 title "Trailer Corruption - CRC Wrong, no strict" ; 347 my $buffer = $good ; 348 my $crc = unpack("N", substr($buffer, -4, 4)); 349 substr($buffer, -4, 4) = pack('N', $crc+1); 350 my $lex = LexFile->new( my $name ); 351 writeFile($name, $buffer) ; 352 353 ok my $gunz = IO::Uncompress::Inflate->new( $name, Append => 1, Strict => 0 ); 354 my $uncomp ; 355 my $status ; 356 1 while ($status = $gunz->read($uncomp)) > 0; 357 cmp_ok $status, '>=', 0 ; 358 ok $gunz->eof() ; 359 ok ! $gunz->trailingData() ; 360 ok $uncomp eq $string; 361 ok $gunz->close ; 362 } 363} 364