1b39c5158Smillert 2b39c5158Smillertuse lib 't'; 3b39c5158Smillertuse strict; 4b39c5158Smillertuse warnings; 5b39c5158Smillertuse bytes; 6b39c5158Smillert 7b39c5158Smillertuse Test::More ; 8b39c5158Smillertuse CompTestUtils; 9b39c5158Smillert 10b39c5158Smillertsub run 11b39c5158Smillert{ 12b39c5158Smillert my $CompressClass = identify(); 13b39c5158Smillert my $UncompressClass = getInverse($CompressClass); 14b39c5158Smillert my $Error = getErrorRef($CompressClass); 15b39c5158Smillert my $UnError = getErrorRef($UncompressClass); 16b39c5158Smillert 17b39c5158Smillert# my $hello = <<EOM ; 18b39c5158Smillert#hello world 19b39c5158Smillert#this is a test 20b39c5158Smillert#some more stuff on this line 21b39c5158Smillert#and finally... 22b39c5158Smillert#EOM 23b39c5158Smillert 24b39c5158Smillert # ASCII hex equivalent of the text above. This makes the test 25b39c5158Smillert # harness behave identically on an EBCDIC platform. 26b39c5158Smillert my $hello = 27b39c5158Smillert "\x68\x65\x6c\x6c\x6f\x20\x77\x6f\x72\x6c\x64\x0a\x74\x68\x69\x73" . 28b39c5158Smillert "\x20\x69\x73\x20\x61\x20\x74\x65\x73\x74\x0a\x73\x6f\x6d\x65\x20" . 29b39c5158Smillert "\x6d\x6f\x72\x65\x20\x73\x74\x75\x66\x66\x20\x6f\x6e\x20\x74\x68" . 30b39c5158Smillert "\x69\x73\x20\x6c\x69\x6e\x65\x0a\x61\x6e\x64\x20\x66\x69\x6e\x61" . 31b39c5158Smillert "\x6c\x6c\x79\x2e\x2e\x2e\x0a" ; 32b39c5158Smillert 33b39c5158Smillert my $blocksize = 10 ; 34b39c5158Smillert 35b39c5158Smillert 36b39c5158Smillert my ($info, $compressed) = mkComplete($CompressClass, $hello); 37b39c5158Smillert 38b39c5158Smillert my $header_size = $info->{HeaderLength}; 39b39c5158Smillert my $trailer_size = $info->{TrailerLength}; 40b39c5158Smillert my $fingerprint_size = $info->{FingerprintLength}; 41b39c5158Smillert ok 1, "Compressed size is " . length($compressed) ; 42b39c5158Smillert ok 1, "Fingerprint size is $fingerprint_size" ; 43b39c5158Smillert ok 1, "Header size is $header_size" ; 44b39c5158Smillert ok 1, "Trailer size is $trailer_size" ; 45b39c5158Smillert 46898184e3Ssthen foreach my $fb ( qw( filehandle buffer ) ) 47898184e3Ssthen { 48b39c5158Smillert for my $trans ( 0 .. 1) 49b39c5158Smillert { 50898184e3Ssthen title "Truncating $CompressClass, Source $fb, Transparent $trans"; 51b39c5158Smillert 52b39c5158Smillert 53b39c5158Smillert foreach my $i (1 .. $fingerprint_size-1) 54b39c5158Smillert { 55*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 56898184e3Ssthen my $input; 57b39c5158Smillert 58b39c5158Smillert title "Fingerprint Truncation - length $i, Transparent $trans"; 59b39c5158Smillert 60b39c5158Smillert my $part = substr($compressed, 0, $i); 61898184e3Ssthen if ($fb eq 'filehandle') 62898184e3Ssthen { 63b39c5158Smillert writeFile($name, $part); 64898184e3Ssthen $input = $name ; 65898184e3Ssthen } 66898184e3Ssthen else 67898184e3Ssthen { 68898184e3Ssthen $input = \$part; 69898184e3Ssthen } 70b39c5158Smillert 71*256a93a4Safresh1 my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, 72b39c5158Smillert -BlockSize => $blocksize, 73*256a93a4Safresh1 -Transparent => $trans ); 74b39c5158Smillert if ($trans) { 75b39c5158Smillert ok $gz; 76b39c5158Smillert ok ! $gz->error() ; 77b39c5158Smillert my $buff ; 78b39c5158Smillert is $gz->read($buff, 5000), length($part) ; 79b39c5158Smillert ok $buff eq $part ; 80b39c5158Smillert ok $gz->eof() ; 81b39c5158Smillert $gz->close(); 82b39c5158Smillert } 83b39c5158Smillert else { 84b39c5158Smillert ok !$gz; 85b39c5158Smillert } 86b39c5158Smillert 87b39c5158Smillert } 88b39c5158Smillert 89b39c5158Smillert # 90b39c5158Smillert # Any header corruption past the fingerprint is considered catastrophic 91b39c5158Smillert # so even if Transparent is set, it should still fail 92b39c5158Smillert # 93b39c5158Smillert foreach my $i ($fingerprint_size .. $header_size -1) 94b39c5158Smillert { 95*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 96898184e3Ssthen my $input; 97b39c5158Smillert 98898184e3Ssthen title "Header Truncation - length $i, Source $fb, Transparent $trans"; 99b39c5158Smillert 100b39c5158Smillert my $part = substr($compressed, 0, $i); 101898184e3Ssthen if ($fb eq 'filehandle') 102898184e3Ssthen { 103b39c5158Smillert writeFile($name, $part); 104898184e3Ssthen $input = $name ; 105898184e3Ssthen } 106898184e3Ssthen else 107898184e3Ssthen { 108898184e3Ssthen $input = \$part; 109898184e3Ssthen } 110898184e3Ssthen 111*256a93a4Safresh1 ok ! defined $UncompressClass->can('new')->( $UncompressClass, $input, 112b39c5158Smillert -BlockSize => $blocksize, 113*256a93a4Safresh1 -Transparent => $trans ); 114b39c5158Smillert #ok $gz->eof() ; 115b39c5158Smillert } 116b39c5158Smillert 117f3efcd01Safresh1 # Test corruption directly after the header 118898184e3Ssthen # In this case the uncompression object will have been created, 119898184e3Ssthen # so need to check that subsequent reads from the object fail 120898184e3Ssthen if ($header_size > 0) 121b39c5158Smillert { 122898184e3Ssthen for my $mode (qw(block line para record slurp)) 123898184e3Ssthen { 124b39c5158Smillert 125898184e3Ssthen title "Corruption after header - Mode $mode, Source $fb, Transparent $trans"; 126898184e3Ssthen 127*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 1286fb12b70Safresh1 my $input; 1296fb12b70Safresh1 130898184e3Ssthen my $part = substr($compressed, 0, $header_size); 131898184e3Ssthen # Append corrupt data 132898184e3Ssthen $part .= "\xFF" x 100 ; 133898184e3Ssthen if ($fb eq 'filehandle') 134898184e3Ssthen { 135b39c5158Smillert writeFile($name, $part); 136898184e3Ssthen $input = $name ; 137898184e3Ssthen } 138898184e3Ssthen else 139898184e3Ssthen { 140898184e3Ssthen $input = \$part; 141898184e3Ssthen } 142898184e3Ssthen 143*256a93a4Safresh1 ok my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, 144b39c5158Smillert -Strict => 1, 145b39c5158Smillert -BlockSize => $blocksize, 146*256a93a4Safresh1 -Transparent => $trans ) 147b39c5158Smillert or diag $$UnError; 148b39c5158Smillert 149b39c5158Smillert my $un ; 150b39c5158Smillert my $status = 1; 151898184e3Ssthen if ($mode eq 'block') 152898184e3Ssthen { 153898184e3Ssthen $status = $gz->read($un) ; 154898184e3Ssthen is $status, -1, "got -1"; 155898184e3Ssthen } 156898184e3Ssthen else 157898184e3Ssthen { 158898184e3Ssthen if ($mode eq 'line') 159898184e3Ssthen { 160898184e3Ssthen $status = <$gz>; 161898184e3Ssthen } 162898184e3Ssthen elsif ($mode eq 'para') 163898184e3Ssthen { 164898184e3Ssthen local $/ = "\n\n"; 165898184e3Ssthen $status = <$gz>; 166898184e3Ssthen } 167898184e3Ssthen elsif ($mode eq 'record') 168898184e3Ssthen { 169898184e3Ssthen local $/ = \ 4; 170898184e3Ssthen $status = <$gz>; 171898184e3Ssthen } 172898184e3Ssthen elsif ($mode eq 'slurp') 173898184e3Ssthen { 174898184e3Ssthen local $/ ; 175898184e3Ssthen $status = <$gz>; 176898184e3Ssthen } 177898184e3Ssthen 178898184e3Ssthen is $status, undef, "got undef"; 179898184e3Ssthen } 180898184e3Ssthen 181898184e3Ssthen ok $gz->error() ; 182898184e3Ssthen $gz->close(); 183898184e3Ssthen } 184898184e3Ssthen } 185898184e3Ssthen 186898184e3Ssthen # Back to truncation tests 187898184e3Ssthen 188898184e3Ssthen foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size) 189898184e3Ssthen { 190898184e3Ssthen next if $i == 0 ; 191898184e3Ssthen 192898184e3Ssthen for my $mode (qw(block line)) 193898184e3Ssthen { 194898184e3Ssthen 195898184e3Ssthen title "Compressed Data Truncation - length $i, MOde $mode, Source $fb, Transparent $trans"; 196898184e3Ssthen 197*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 1986fb12b70Safresh1 my $input; 1996fb12b70Safresh1 200898184e3Ssthen my $part = substr($compressed, 0, $i); 201898184e3Ssthen if ($fb eq 'filehandle') 202898184e3Ssthen { 203898184e3Ssthen writeFile($name, $part); 204898184e3Ssthen $input = $name ; 205898184e3Ssthen } 206898184e3Ssthen else 207898184e3Ssthen { 208898184e3Ssthen $input = \$part; 209898184e3Ssthen } 210898184e3Ssthen 211*256a93a4Safresh1 ok my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, 212898184e3Ssthen -Strict => 1, 213898184e3Ssthen -BlockSize => $blocksize, 214*256a93a4Safresh1 -Transparent => $trans ) 215898184e3Ssthen or diag $$UnError; 216898184e3Ssthen 217898184e3Ssthen my $un ; 218898184e3Ssthen if ($mode eq 'block') 219898184e3Ssthen { 220898184e3Ssthen my $status = 1 ; 221b39c5158Smillert $status = $gz->read($un) while $status > 0 ; 222b39c5158Smillert cmp_ok $status, "<", 0 ; 223898184e3Ssthen } 224898184e3Ssthen else 225898184e3Ssthen { 226898184e3Ssthen 1 while <$gz> ; 227898184e3Ssthen } 228b39c5158Smillert ok $gz->error() ; 229898184e3Ssthen cmp_ok $gz->errorNo(), '<', 0 ; 230f3efcd01Safresh1 # ok $gz->eof() 231f3efcd01Safresh1 # or die "EOF"; 232b39c5158Smillert $gz->close(); 233b39c5158Smillert } 234898184e3Ssthen } 235b39c5158Smillert 236f3efcd01Safresh1 # RawDeflate and Zstandard do not have a trailer 237b39c5158Smillert next if $CompressClass eq 'IO::Compress::RawDeflate' ; 238f3efcd01Safresh1 next if $CompressClass eq 'IO::Compress::Zstd' ; 239b39c5158Smillert 240b39c5158Smillert title "Compressed Trailer Truncation"; 241b39c5158Smillert foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 ) 242b39c5158Smillert { 243b39c5158Smillert foreach my $lax (0, 1) 244b39c5158Smillert { 245*256a93a4Safresh1 my $lex = LexFile->new( my $name ); 246898184e3Ssthen my $input; 247b39c5158Smillert 248b39c5158Smillert ok 1, "Compressed Trailer Truncation - Length $i, Lax $lax, Transparent $trans" ; 249b39c5158Smillert my $part = substr($compressed, 0, $i); 250898184e3Ssthen if ($fb eq 'filehandle') 251898184e3Ssthen { 252b39c5158Smillert writeFile($name, $part); 253898184e3Ssthen $input = $name ; 254898184e3Ssthen } 255898184e3Ssthen else 256898184e3Ssthen { 257898184e3Ssthen $input = \$part; 258898184e3Ssthen } 259898184e3Ssthen 260*256a93a4Safresh1 ok my $gz = $UncompressClass->can('new')->( $UncompressClass, $input, 261b39c5158Smillert -BlockSize => $blocksize, 262b39c5158Smillert -Strict => !$lax, 263b39c5158Smillert -Append => 1, 264*256a93a4Safresh1 -Transparent => $trans ); 265b39c5158Smillert my $un = ''; 266b39c5158Smillert my $status = 1 ; 267b39c5158Smillert $status = $gz->read($un) while $status > 0 ; 268b39c5158Smillert 269b39c5158Smillert if ($lax) 270b39c5158Smillert { 271b39c5158Smillert is $un, $hello; 272b39c5158Smillert is $status, 0 273b39c5158Smillert or diag "Status $status Error is " . $gz->error() ; 274b39c5158Smillert ok $gz->eof() 275b39c5158Smillert or diag "Status $status Error is " . $gz->error() ; 276b39c5158Smillert ok ! $gz->error() ; 277b39c5158Smillert } 278b39c5158Smillert else 279b39c5158Smillert { 280b39c5158Smillert cmp_ok $status, "<", 0 281b39c5158Smillert or diag "Status $status Error is " . $gz->error() ; 282b39c5158Smillert ok $gz->eof() 283b39c5158Smillert or diag "Status $status Error is " . $gz->error() ; 284b39c5158Smillert ok $gz->error() ; 285b39c5158Smillert } 286b39c5158Smillert 287b39c5158Smillert $gz->close(); 288b39c5158Smillert } 289b39c5158Smillert } 290b39c5158Smillert } 291b39c5158Smillert } 292898184e3Ssthen} 293b39c5158Smillert 294b39c5158Smillert1; 295