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

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