ext/Compress/Zlib/t/11truncate.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 => 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 $lex = new LexFile my $name ;
 105
 106             ok 1, "Length $i" ;
 107             my $part = substr($compressed, 0, $i);
 108             writeFile($name, $part);
 109
 110             my $gz = new $UncompressClass $name,
 111                                           -BlockSize   => $blocksize,
 112                                           -Transparent => $trans;
 113             if ($trans) {
 114                 ok $gz;
 115                 ok ! $gz->error() ;
 116                 my $buff ;
 117                 ok $gz->read($buff) == length($part) ;
 118                 ok $buff eq $part ;
 119                 ok $gz->eof() ;
 120                 $gz->close();
 121             }
 122             else {
 123                 ok !$gz;
 124             }
 125
 126         }
 127
 128         title "Header Truncation";
 129         #
 130         # Any header corruption past the fingerprint is considered catastrophic
 131         # so even if Transparent is set, it should still fail
 132         #
 133         foreach my $i (2 .. $header_size -1)
 134         {
 135             my $lex = new LexFile my $name ;
 136
 137             ok 1, "Length $i" ;
 138             my $part = substr($compressed, 0, $i);
 139             writeFile($name, $part);
 140             ok ! defined new $UncompressClass $name,
 141                                               -BlockSize   => $blocksize,
 142                                               -Transparent => $trans;
 143             #ok $gz->eof() ;
 144         }
 145
 146         title "Compressed Data Truncation";
 147         foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size)
 148         {
 149
 150             my $lex = new LexFile my $name ;
 151
 152             ok 1, "Length $i" ;
 153             my $part = substr($compressed, 0, $i);
 154             writeFile($name, $part);
 155             ok my $gz = new $UncompressClass $name,
 156                                              -BlockSize   => $blocksize,
 157                                              -Transparent => $trans;
 158             my $un ;
 159             my $status = 0 ;
 160             $status = $gz->read($un) while $status >= 0 ;
 161             ok $status < 0 ;
 162             ok $gz->eof() ;
 163             ok $gz->error() ;
 164             $gz->close();
 165         }
 166
 167         # RawDeflate does not have a trailer
 168         next if $CompressClass eq 'IO::Compress::RawDeflate' ;
 169
 170         title "Compressed Trailer Truncation";
 171         foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 )
 172         {
 173             foreach my $lax (0, 1)
 174             {
 175                 my $lex = new LexFile my $name ;
 176
 177                 ok 1, "Length $i, Lax $lax" ;
 178                 my $part = substr($compressed, 0, $i);
 179                 writeFile($name, $part);
 180                 ok my $gz = new $UncompressClass $name,
 181                                                  -BlockSize   => $blocksize,
 182                                                  -Strict      => !$lax,
 183                                                  -Append      => 1,
 184                                                  -Transparent => $trans;
 185                 my $un = '';
 186                 my $status = 1 ;
 187                 $status = $gz->read($un) while $status > 0 ;
 188
 189                 if ($lax)
 190                 {
 191                     is $un, $hello;
 192                     is $status, 0
 193                         or diag "Status $status Error is " . $gz->error() ;
 194                     ok $gz->eof()
 195                         or diag "Status $status Error is " . $gz->error() ;
 196                     ok ! $gz->error() ;
 197                 }
 198                 else
 199                 {
 200                     ok $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
 207                 $gz->close();
 208             }
 209         }
 210     }
 211 }
 212
 213
 214 foreach my $CompressClass ( 'IO::Compress::RawDeflate')
 215 {
 216     my $UncompressClass = getInverse($CompressClass);
 217     my $Error = getErrorRef($UncompressClass);
 218
 219     my $compressed ;
 220         ok( my $x = new IO::Compress::RawDeflate \$compressed);
 221         ok $x->write($hello) ;
 222         ok $x->close ;
 223
 224
 225     my $cc = $compressed ;
 226
 227     my $gz ;
 228     ok($gz = new $UncompressClass(\$cc,
 229                                   -Transparent => 0))
 230             or diag "$$Error\n";
 231     my $un;
 232     ok $gz->read($un) > 0 ;
 233     ok $gz->close();
 234     ok $un eq $hello ;
 235
 236     for my $trans (0 .. 1)
 237     {
 238         title "Testing $CompressClass, Transparent = $trans";
 239
 240         my $info = $gz->getHeaderInfo() ;
 241         my $header_size = $info->{HeaderLength};
 242         my $trailer_size = $info->{TrailerLength};
 243         ok 1, "Compressed size is " . length($compressed) ;
 244         ok 1, "Header size is $header_size" ;
 245         ok 1, "Trailer size is $trailer_size" ;
 246
 247
 248         title "Compressed Data Truncation";
 249         foreach my $i (0 .. $blocksize)
 250         {
 251
 252             my $lex = new LexFile my $name ;
 253
 254             ok 1, "Length $i" ;
 255             my $part = substr($compressed, 0, $i);
 256             writeFile($name, $part);
 257             my $gz = new $UncompressClass $name,
 258                                        -BlockSize   => $blocksize,
 259                                        -Transparent => $trans;
 260             if ($trans) {
 261                 ok $gz;
 262                 ok ! $gz->error() ;
 263                 my $buff = '';
 264                 ok $gz->read($buff) == length $part ;
 265                 ok $buff eq $part ;
 266                 ok $gz->eof() ;
 267                 $gz->close();
 268             }
 269             else {
 270                 ok !$gz;
 271             }
 272         }
 273
 274         foreach my $i ($blocksize+1 .. length($compressed)-1)
 275         {
 276
 277             my $lex = new LexFile my $name ;
 278
 279             ok 1, "Length $i" ;
 280             my $part = substr($compressed, 0, $i);
 281             writeFile($name, $part);
 282             ok my $gz = new $UncompressClass $name,
 283                                              -BlockSize   => $blocksize,
 284                                              -Transparent => $trans;
 285             my $un ;
 286             my $status = 0 ;
 287             $status = $gz->read($un) while $status >= 0 ;
 288             ok $status < 0 ;
 289             ok $gz->eof() ;
 290             ok $gz->error() ;
 291             $gz->close();
 292         }
 293     }
 294
 295 }
 296