ext/Compress/Zlib/t/11truncate.t

   1 BEGIN {
   2     if ($ENV{PERL_CORE}) {
   3         chdir 't' if -d 't';
   4         @INC = '../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 => 2374 + $extra;
  23
  24     use_ok('Compress::Zlib', 2) ;
  25
  26     use_ok('IO::Compress::Gzip', qw($GzipError)) ;
  27     use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
  28
  29     use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
  30     use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
  31
  32     use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
  33     use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
  34
  35 }
  36
  37
  38 my $hello = <<EOM ;
  39 hello world
  40 this is a test
  41 some more stuff on this line
  42 ad finally...
  43 EOM
  44
  45 my $blocksize = 10 ;
  46
  47
  48 foreach my $CompressClass ('IO::Compress::Gzip', 'IO::Compress::Deflate')
  49 {
  50     my $UncompressClass = getInverse($CompressClass);
  51
  52
  53     my $compressed ;
  54     my $cc ;
  55     my $gz ;
  56     if ($CompressClass eq 'IO::Compress::Gzip') {
  57         ok( my $x = new IO::Compress::Gzip \$compressed,
  58                                  -Name       => "My name",
  59                                  -Comment    => "a comment",
  60                                  -ExtraField => ['ab' => "extra"],
  61                                  -HeaderCRC  => 1);
  62         ok $x->write($hello) ;
  63         ok $x->close ;
  64         $cc = $compressed ;
  65
  66         ok($gz = new IO::Uncompress::Gunzip \$cc,
  67                                 -Transparent => 0)
  68                 or diag "$GunzipError";
  69         my $un;
  70         ok $gz->read($un) > 0 ;
  71         ok $gz->close();
  72         ok $un eq $hello ;
  73     }
  74     else {
  75         ok( my $x = new $CompressClass(\$compressed));
  76         ok $x->write($hello) ;
  77         ok $x->close ;
  78         $cc = $compressed ;
  79
  80         ok($gz = new $UncompressClass(\$cc,
  81                                       -Transparent => 0))
  82                 or diag "$GunzipError";
  83         my $un;
  84         ok $gz->read($un) > 0 ;
  85         ok $gz->close();
  86         ok $un eq $hello ;
  87     }
  88
  89
  90     for my $trans ( 0 .. 1)
  91     {
  92         title "Testing $CompressClass, Transparent $trans";
  93
  94         my $info = $gz->getHeaderInfo() ;
  95         my $header_size = $info->{HeaderLength};
  96         my $trailer_size = $info->{TrailerLength};
  97         ok 1, "Compressed size is " . length($compressed) ;
  98         ok 1, "Header size is $header_size" ;
  99         ok 1, "Trailer size is $trailer_size" ;
 100
 101         title "Fingerprint Truncation";
 102         foreach my $i (1)
 103         {
 104             my $name = "test.gz" ;
 105             unlink $name ;
 106             my $lex = new LexFile $name ;
 107
 108             ok 1, "Length $i" ;
 109             my $part = substr($compressed, 0, $i);
 110             writeFile($name, $part);
 111
 112             my $gz = new $UncompressClass $name,
 113                                           -BlockSize   => $blocksize,
 114                                           -Transparent => $trans;
 115             if ($trans) {
 116                 ok $gz;
 117                 ok ! $gz->error() ;
 118                 my $buff ;
 119                 ok $gz->read($buff) == length($part) ;
 120                 ok $buff eq $part ;
 121                 ok $gz->eof() ;
 122                 $gz->close();
 123             }
 124             else {
 125                 ok !$gz;
 126             }
 127
 128         }
 129
 130         title "Header Truncation";
 131         #
 132         # Any header corruption past the fingerprint is considered catastrophic
 133         # so even if Transparent is set, it should still fail
 134         #
 135         foreach my $i (2 .. $header_size -1)
 136         {
 137             my $name = "test.gz" ;
 138             unlink $name ;
 139             my $lex = new LexFile $name ;
 140
 141             ok 1, "Length $i" ;
 142             my $part = substr($compressed, 0, $i);
 143             writeFile($name, $part);
 144             ok ! defined new $UncompressClass $name,
 145                                               -BlockSize   => $blocksize,
 146                                               -Transparent => $trans;
 147             #ok $gz->eof() ;
 148         }
 149
 150         title "Compressed Data Truncation";
 151         foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size)
 152         {
 153
 154             my $name = "test.gz" ;
 155             unlink $name ;
 156             my $lex = new LexFile $name ;
 157
 158             ok 1, "Length $i" ;
 159             my $part = substr($compressed, 0, $i);
 160             writeFile($name, $part);
 161             ok my $gz = new $UncompressClass $name,
 162                                              -BlockSize   => $blocksize,
 163                                              -Transparent => $trans;
 164             my $un ;
 165             my $status = 0 ;
 166             $status = $gz->read($un) while $status >= 0 ;
 167             ok $status < 0 ;
 168             ok $gz->eof() ;
 169             ok $gz->error() ;
 170             $gz->close();
 171         }
 172
 173         # RawDeflate does not have a trailer
 174         next if $CompressClass eq 'IO::Compress::RawDeflate' ;
 175
 176         title "Compressed Trailer Truncation";
 177         foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 )
 178         {
 179             foreach my $lax (0, 1)
 180             {
 181                 my $name = "test.gz" ;
 182                 unlink $name ;
 183                 my $lex = new LexFile $name ;
 184
 185                 ok 1, "Length $i, Lax $lax" ;
 186                 my $part = substr($compressed, 0, $i);
 187                 writeFile($name, $part);
 188                 ok my $gz = new $UncompressClass $name,
 189                                                  -BlockSize   => $blocksize,
 190                                                  -Strict      => !$lax,
 191                                                  -Append      => 1,
 192                                                  -Transparent => $trans;
 193                 my $un = '';
 194                 my $status = 1 ;
 195                 $status = $gz->read($un) while $status > 0 ;
 196
 197                 if ($lax)
 198                 {
 199                     is $un, $hello;
 200                     is $status, 0
 201                         or diag "Status $status Error is " . $gz->error() ;
 202                     ok $gz->eof()
 203                         or diag "Status $status Error is " . $gz->error() ;
 204                     ok ! $gz->error() ;
 205                 }
 206                 else
 207                 {
 208                     ok $status < 0
 209                         or diag "Status $status Error is " . $gz->error() ;
 210                     ok $gz->eof()
 211                         or diag "Status $status Error is " . $gz->error() ;
 212                     ok $gz->error() ;
 213                 }
 214
 215                 $gz->close();
 216             }
 217         }
 218     }
 219 }
 220
 221
 222 foreach my $CompressClass ( 'IO::Compress::RawDeflate')
 223 {
 224     my $UncompressClass = getInverse($CompressClass);
 225     my $Error = getErrorRef($UncompressClass);
 226
 227     my $compressed ;
 228         ok( my $x = new IO::Compress::RawDeflate \$compressed);
 229         ok $x->write($hello) ;
 230         ok $x->close ;
 231
 232
 233     my $cc = $compressed ;
 234
 235     my $gz ;
 236     ok($gz = new $UncompressClass(\$cc,
 237                                   -Transparent => 0))
 238             or diag "$$Error\n";
 239     my $un;
 240     ok $gz->read($un) > 0 ;
 241     ok $gz->close();
 242     ok $un eq $hello ;
 243
 244     for my $trans (0 .. 1)
 245     {
 246         title "Testing $CompressClass, Transparent = $trans";
 247
 248         my $info = $gz->getHeaderInfo() ;
 249         my $header_size = $info->{HeaderLength};
 250         my $trailer_size = $info->{TrailerLength};
 251         ok 1, "Compressed size is " . length($compressed) ;
 252         ok 1, "Header size is $header_size" ;
 253         ok 1, "Trailer size is $trailer_size" ;
 254
 255
 256         title "Compressed Data Truncation";
 257         foreach my $i (0 .. $blocksize)
 258         {
 259
 260             my $name = "test.gz" ;
 261             unlink $name ;
 262             my $lex = new LexFile $name ;
 263
 264             ok 1, "Length $i" ;
 265             my $part = substr($compressed, 0, $i);
 266             writeFile($name, $part);
 267             my $gz = new $UncompressClass $name,
 268                                        -BlockSize   => $blocksize,
 269                                        -Transparent => $trans;
 270             if ($trans) {
 271                 ok $gz;
 272                 ok ! $gz->error() ;
 273                 my $buff = '';
 274                 ok $gz->read($buff) == length $part ;
 275                 ok $buff eq $part ;
 276                 ok $gz->eof() ;
 277                 $gz->close();
 278             }
 279             else {
 280                 ok !$gz;
 281             }
 282         }
 283
 284         foreach my $i ($blocksize+1 .. length($compressed)-1)
 285         {
 286
 287             my $name = "test.gz" ;
 288             unlink $name ;
 289             my $lex = new LexFile $name ;
 290
 291             ok 1, "Length $i" ;
 292             my $part = substr($compressed, 0, $i);
 293             writeFile($name, $part);
 294             ok my $gz = new $UncompressClass $name,
 295                                              -BlockSize   => $blocksize,
 296                                              -Transparent => $trans;
 297             my $un ;
 298             my $status = 0 ;
 299             $status = $gz->read($un) while $status >= 0 ;
 300             ok $status < 0 ;
 301             ok $gz->eof() ;
 302             ok $gz->error() ;
 303             $gz->close();
 304         }
 305     }
 306
 307 }
 308