ext/Compress/Zlib/t/10defhdr.t

   1 BEGIN {
   2     if ($ENV{PERL_CORE}) {
   3         chdir 't' if -d 't';
   4         @INC = ("../lib", "lib");
   5     }
   6 }
   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