BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
@INC = ("../lib", "lib/compress");
}
}
use lib qw(t t/compress);
use strict;
use warnings;
use bytes;
use Test::More ;
use CompTestUtils;
BEGIN {
# use Test::NoWarnings, if available
my $extra = 0 ;
$extra = 1
if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
plan tests => 918 + $extra ;
use_ok('Compress::Raw::Zlib') ;
use_ok('IO::Compress::Gzip::Constants') ;
use_ok('IO::Compress::Gzip', qw($GzipError)) ;
use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
}
# Check the Gzip Header Parameters
#========================================
my $ThisOS_code = $Compress::Raw::Zlib::gzip_os_code;
my $lex = new LexFile my $name ;
{
title "Check Defaults";
# Check Name defaults undef, no name, no comment
# and Time can be explicitly set.
my $hdr = readHeaderInfo($name, -Time => 1234);
is $hdr->{Time}, 1234;
ok ! defined $hdr->{Name};
is $hdr->{MethodName}, 'Deflated';
is $hdr->{ExtraFlags}, 0;
is $hdr->{MethodID}, Z_DEFLATED;
is $hdr->{OsID}, $ThisOS_code ;
ok ! defined $hdr->{Comment} ;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! defined $hdr->{HeaderCRC} ;
ok ! $hdr->{isMinimalHeader} ;
}
{
title "Check name can be different from filename" ;
# Check Name can be different from filename
# Comment and Extra can be set
# Can specify a zero Time
my $comment = "This is a Comment" ;
my $extra = "A little something extra" ;
my $aname = "a new name" ;
my $hdr = readHeaderInfo $name,
-Strict => 0,
-Name => $aname,
-Comment => $comment,
-ExtraField => $extra,
-Time => 0 ;
ok $hdr->{Time} == 0;
ok $hdr->{Name} eq $aname;
ok $hdr->{MethodName} eq 'Deflated';
ok $hdr->{MethodID} == 8;
is $hdr->{ExtraFlags}, 0;
ok $hdr->{Comment} eq $comment ;
is $hdr->{OsID}, $ThisOS_code ;
ok ! $hdr->{isMinimalHeader} ;
ok ! defined $hdr->{HeaderCRC} ;
}
{
title "Check Time defaults to now" ;
# Check Time defaults to now
# and that can have empty name, comment and extrafield
my $before = time ;
my $hdr = readHeaderInfo $name,
-TextFlag => 1,
-Name => "",
-Comment => "",
-ExtraField => "";
my $after = time ;
ok $hdr->{Time} >= $before ;
ok $hdr->{Time} <= $after ;
ok defined $hdr->{Name} ;
ok $hdr->{Name} eq "";
ok defined $hdr->{Comment} ;
ok $hdr->{Comment} eq "";
ok defined $hdr->{ExtraFieldRaw} ;
ok $hdr->{ExtraFieldRaw} eq "";
is $hdr->{ExtraFlags}, 0;
ok ! $hdr->{isMinimalHeader} ;
ok $hdr->{TextFlag} ;
ok ! defined $hdr->{HeaderCRC} ;
is $hdr->{OsID}, $ThisOS_code ;
}
{
title "can have null extrafield" ;
my $before = time ;
my $hdr = readHeaderInfo $name,
-strict => 0,
-Name => "a",
-Comment => "b",
-ExtraField => "\x00";
my $after = time ;
ok $hdr->{Time} >= $before ;
ok $hdr->{Time} <= $after ;
ok $hdr->{Name} eq "a";
ok $hdr->{Comment} eq "b";
is $hdr->{ExtraFlags}, 0;
ok $hdr->{ExtraFieldRaw} eq "\x00";
ok ! $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok ! defined $hdr->{HeaderCRC} ;
is $hdr->{OsID}, $ThisOS_code ;
}
{
title "can have undef name, comment, time and extrafield" ;
my $hdr = readHeaderInfo $name,
-Name => undef,
-Comment => undef,
-ExtraField => undef,
-Time => undef;
ok $hdr->{Time} == 0;
ok ! defined $hdr->{Name} ;
ok ! defined $hdr->{Comment} ;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok ! defined $hdr->{HeaderCRC} ;
is $hdr->{OsID}, $ThisOS_code ;
}
for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D")
{
title "Comment with $value" ;
my $v = pack "h*", $value;
my $comment = "my${v}comment$v";
my $hdr = readHeaderInfo $name,
Time => 0,
-TextFlag => 1,
-Name => "",
-Comment => $comment,
-ExtraField => "";
my $after = time ;
is $hdr->{Time}, 0 ;
ok defined $hdr->{Name} ;
ok $hdr->{Name} eq "";
ok defined $hdr->{Comment} ;
is $hdr->{Comment}, $comment;
ok defined $hdr->{ExtraFieldRaw} ;
ok $hdr->{ExtraFieldRaw} eq "";
is $hdr->{ExtraFlags}, 0;
ok ! $hdr->{isMinimalHeader} ;
ok $hdr->{TextFlag} ;
ok ! defined $hdr->{HeaderCRC} ;
is $hdr->{OsID}, $ThisOS_code ;
}
{
title "Check crchdr" ;
my $hdr = readHeaderInfo $name, -HeaderCRC => 1;
ok ! defined $hdr->{Name};
is $hdr->{ExtraFlags}, 0;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! defined $hdr->{Comment} ;
ok ! $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok defined $hdr->{HeaderCRC} ;
is $hdr->{OsID}, $ThisOS_code ;
}
{
title "Check ExtraFlags" ;
my $hdr = readHeaderInfo $name, -Level => Z_BEST_SPEED;
ok ! defined $hdr->{Name};
is $hdr->{ExtraFlags}, 4;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! defined $hdr->{Comment} ;
ok ! $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok ! defined $hdr->{HeaderCRC} ;
$hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION;
ok ! defined $hdr->{Name};
is $hdr->{ExtraFlags}, 2;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! defined $hdr->{Comment} ;
ok ! $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok ! defined $hdr->{HeaderCRC} ;
$hdr = readHeaderInfo $name, -Level => Z_BEST_COMPRESSION,
-ExtraFlags => 42;
ok ! defined $hdr->{Name};
is $hdr->{ExtraFlags}, 42;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! defined $hdr->{Comment} ;
ok ! $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok ! defined $hdr->{HeaderCRC} ;
}
{
title "OS Code" ;
for my $code ( -1, undef, '', 'fred' )
{
my $code_name = defined $code ? "'$code'" : "'undef'";
eval { new IO::Compress::Gzip $name, -OS_Code => $code } ;
like $@, mkErr("^IO::Compress::Gzip: Parameter 'OS_Code' must be an unsigned int, got $code_name"),
" Trap OS Code $code_name";
}
for my $code ( qw( 256 ) )
{
eval { ok ! new IO::Compress::Gzip($name, OS_Code => $code) };
like $@, mkErr("OS_Code must be between 0 and 255, got '$code'"),
" Trap OS Code $code";
like $GzipError, "/OS_Code must be between 0 and 255, got '$code'/",
" Trap OS Code $code";
}
for my $code ( qw(0 1 12 254 255) )
{
my $hdr = readHeaderInfo $name, OS_Code => $code;
is $hdr->{OsID}, $code, " Code is $code" ;
}
}
{
title 'Check ExtraField';
my @tests = (
[1, ['AB' => ''] => [['AB'=>'']] ],
[1, {'AB' => ''} => [['AB'=>'']] ],
[1, ['AB' => 'Fred'] => [['AB'=>'Fred']] ],
[1, {'AB' => 'Fred'} => [['AB'=>'Fred']] ],
[1, ['Xx' => '','AB' => 'Fred'] => [['Xx' => ''],['AB'=>'Fred']] ],
[1, ['Xx' => '','Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred']] ],
[1, ['Xx' => '',
'Xx' => 'Fred',
'Xx' => 'Fred'] => [['Xx' => ''],['Xx'=>'Fred'],
['Xx'=>'Fred']] ],
[1, [ ['Xx' => 'a'],
['AB' => 'Fred'] ] => [['Xx' => 'a'],['AB'=>'Fred']] ],
[0, {'AB' => 'Fred',
'Pq' => 'r',
"\x01\x02" => "\x03"} => [['AB'=>'Fred'],
['Pq'=>'r'],
["\x01\x02"=>"\x03"]] ],
[1, ['AB' => 'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE] =>
[['AB'=>'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE]] ],
);
foreach my $test (@tests) {
my ($order, $input, $result) = @$test ;
ok my $x = new IO::Compress::Gzip $name,
-ExtraField => $input,
-HeaderCRC => 1
or diag "GzipError is $GzipError" ; ;
my $string = "abcd" ;
ok $x->write($string) ;
ok $x->close ;
#is GZreadFile($name), $string ;
ok $x = new IO::Uncompress::Gunzip $name,
#-Strict => 1,
-ParseExtra => 1
or diag "GunzipError is $GunzipError" ; ;
my $hdr = $x->getHeaderInfo();
ok $hdr;
ok ! defined $hdr->{Name};
ok ! defined $hdr->{Comment} ;
ok ! $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok defined $hdr->{HeaderCRC} ;
ok defined $hdr->{ExtraFieldRaw} ;
ok defined $hdr->{ExtraField} ;
my $extra = $hdr->{ExtraField} ;
if ($order) {
eq_array $extra, $result;
} else {
eq_set $extra, $result;
}
}
}
{
title 'Write Invalid ExtraField';
my $prefix = 'Error with ExtraField Parameter: ';
my @tests = (
[ sub{ "abc" } => "Not a scalar, array ref or hash ref"],
[ [ "a" ] => "Not even number of elements"],
[ [ "a" => "fred" ] => 'SubField ID not two chars long'],
[ [ "a\x00" => "fred" ] => 'SubField ID 2nd byte is 0x00'],
[ [ [ {}, "abc" ]] => "SubField ID is a reference"],
[ [ [ "ab", \1 ]] => "SubField Data is a reference"],
[ [ {"a" => "fred"} ] => "Not list of lists"],
[ [ ['ab'=>'x'],{"a" => "fred"} ] => "Not list of lists"],
[ [ ["aa"] ] => "SubField must have two parts"],
[ [ ["aa", "b", "c"] ] => "SubField must have two parts"],
[ [ ["ab" => 'x' x (GZIP_FEXTRA_SUBFIELD_MAX_SIZE + 1) ] ]
=> "SubField Data too long"],
[ { 'abc', 1 } => "SubField ID not two chars long"],
[ { \1 , "abc" } => "SubField ID not two chars long"],
[ { "ab", \1 } => "SubField Data is a reference"],
);
foreach my $test (@tests) {
my ($input, $string) = @$test ;
my $buffer ;
my $x ;
eval { $x = new IO::Compress::Gzip \$buffer, -ExtraField => $input; };
like $@, mkErr("$prefix$string");
like $GzipError, "/$prefix$string/";
ok ! $x ;
}
}
{
# Corrupt ExtraField
my @tests = (
["Sub-field truncated",
"Error with ExtraField Parameter: Truncated in FEXTRA Body Section",
"Header Error: Truncated in FEXTRA Body Section",
['a', undef, undef] ],
["Length of field incorrect",
"Error with ExtraField Parameter: Truncated in FEXTRA Body Section",
"Header Error: Truncated in FEXTRA Body Section",
["ab", 255, "abc"] ],
["Length of 2nd field incorrect",
"Error with ExtraField Parameter: Truncated in FEXTRA Body Section",
"Header Error: Truncated in FEXTRA Body Section",
["ab", 3, "abc"], ["de", 7, "x"] ],
["Length of 2nd field incorrect",
"Error with ExtraField Parameter: SubField ID 2nd byte is 0x00",
"Header Error: SubField ID 2nd byte is 0x00",
["a\x00", 3, "abc"], ["de", 7, "x"] ],
);
foreach my $test (@tests)
{
my $name = shift @$test;
my $gzip_error = shift @$test;
my $gunzip_error = shift @$test;
title "Read Corrupt ExtraField - $name" ;
my $input = '';
for my $field (@$test)
{
my ($id, $len, $data) = @$field;
$input .= $id if defined $id ;
$input .= pack("v", $len) if defined $len ;
$input .= $data if defined $data;
}
#hexDump(\$input);
my $buffer ;
my $x ;
eval {$x = new IO::Compress::Gzip \$buffer, -ExtraField => $input, Strict => 1; };
like $@, mkErr("$gzip_error"), " $name";
like $GzipError, "/$gzip_error/", " $name";
ok ! $x, " IO::Compress::Gzip fails";
like $GzipError, "/$gzip_error/", " $name";
foreach my $check (0, 1)
{
ok $x = new IO::Compress::Gzip \$buffer,
ExtraField => $input,
Strict => 0
or diag "GzipError is $GzipError" ;
my $string = "abcd" ;
$x->write($string) ;
$x->close ;
is anyUncompress(\$buffer), $string ;
$x = new IO::Uncompress::Gunzip \$buffer,
Strict => 0,
Transparent => 0,
ParseExtra => $check;
if ($check) {
ok ! $x ;
like $GunzipError, "/^$gunzip_error/";
}
else {
ok $x ;
}
}
}
}
{
title 'Check Minimal';
ok my $x = new IO::Compress::Gzip $name, -Minimal => 1;
my $string = "abcd" ;
ok $x->write($string) ;
ok $x->close ;
#is GZreadFile($name), $string ;
ok $x = new IO::Uncompress::Gunzip $name ;
my $hdr = $x->getHeaderInfo();
ok $hdr;
ok $hdr->{Time} == 0;
is $hdr->{ExtraFlags}, 0;
ok ! defined $hdr->{Name} ;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! defined $hdr->{Comment} ;
is $hdr->{OsName}, 'Unknown' ;
is $hdr->{MethodName}, "Deflated";
is $hdr->{Flags}, 0;
ok $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok $x->close ;
}
{
title "Check Minimal + no compressed data";
# This is the smallest possible gzip file (20 bytes)
ok my $x = new IO::Compress::Gzip $name, -Minimal => 1;
isa_ok $x, "IO::Compress::Gzip";
ok $x->close, "closed" ;
ok $x = new IO::Uncompress::Gunzip $name, -Append => 0 ;
isa_ok $x, "IO::Uncompress::Gunzip";
my $data ;
my $status = 1;
ok $x->eof(), "eof" ;
$status = $x->read($data)
while $status > 0;
is $status, 0, "status == 0" ;
is $data, '', "empty string";
ok ! $x->error(), "no error" ;
ok $x->eof(), "eof" ;
my $hdr = $x->getHeaderInfo();
ok $hdr;
ok defined $hdr->{ISIZE} ;
is $hdr->{ISIZE}, 0;
ok defined $hdr->{CRC32} ;
is $hdr->{CRC32}, 0;
is $hdr->{Time}, 0;
ok ! defined $hdr->{Name} ;
ok ! defined $hdr->{ExtraFieldRaw} ;
ok ! defined $hdr->{Comment} ;
is $hdr->{OsName}, 'Unknown' ;
is $hdr->{MethodName}, "Deflated";
is $hdr->{Flags}, 0;
ok $hdr->{isMinimalHeader} ;
ok ! $hdr->{TextFlag} ;
ok $x->close ;
}
{
title "Header Corruption Tests";
my $string = <<EOM;
some text
EOM
my $good = '';
ok my $x = new IO::Compress::Gzip \$good, -HeaderCRC => 1 ;
ok $x->write($string) ;
ok $x->close ;
{
title "Header Corruption - Fingerprint wrong 1st byte" ;
my $buffer = $good ;
substr($buffer, 0, 1) = 'x' ;
ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ;
ok $GunzipError =~ /Header Error: Bad Magic/;
}
{
title "Header Corruption - Fingerprint wrong 2nd byte" ;
my $buffer = $good ;
substr($buffer, 1, 1) = "\xFF" ;
ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ;
ok $GunzipError =~ /Header Error: Bad Magic/;
#print "$GunzipError\n";
}
{
title "Header Corruption - CM not 8";
my $buffer = $good ;
substr($buffer, 2, 1) = 'x' ;
ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ;
like $GunzipError, '/Header Error: Not Deflate \(CM is \d+\)/';
}
{
title "Header Corruption - Use of Reserved Flags";
my $buffer = $good ;
substr($buffer, 3, 1) = "\xff";
ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0 ;
like $GunzipError, '/Header Error: Use of Reserved Bits in FLG field./';
}
{
title "Header Corruption - Fail HeaderCRC";
my $buffer = $good ;
substr($buffer, 10, 1) = chr((ord(substr($buffer, 10, 1)) + 1) & 0xFF);
ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0, Strict => 1
or print "# $GunzipError\n";
like $GunzipError, '/Header Error: CRC16 mismatch/'
#or diag "buffer length " . length($buffer);
or hexDump(\$good), hexDump(\$buffer);
}
}
{
title "ExtraField max raw size";
my $x ;
my $store = "x" x GZIP_FEXTRA_MAX_SIZE ;
{
my $z = new IO::Compress::Gzip(\$x, ExtraField => $store, Strict => 0) ;
ok $z, "Created IO::Compress::Gzip object" ;
}
my $gunz = new IO::Uncompress::Gunzip \$x, Strict => 0;
ok $gunz, "Created IO::Uncompress::Gunzip object" ;
my $hdr = $gunz->getHeaderInfo();
ok $hdr;
is $hdr->{ExtraFieldRaw}, $store ;
}
{
title "Header Corruption - ExtraField too big";
my $x;
eval { new IO::Compress::Gzip(\$x, -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;};
like $@, mkErr('Error with ExtraField Parameter: Too Large');
like $GzipError, '/Error with ExtraField Parameter: Too Large/';
}
{
title "Header Corruption - Create Name with Illegal Chars";
my $x;
eval { new IO::Compress::Gzip \$x, -Name => "fred\x02" };
like $@, mkErr('Non ISO 8859-1 Character found in Name');
like $GzipError, '/Non ISO 8859-1 Character found in Name/';
ok my $gz = new IO::Compress::Gzip \$x,
-Strict => 0,
-Name => "fred\x02" ;
ok $gz->close();
ok ! new IO::Uncompress::Gunzip \$x,
-Transparent => 0,
-Strict => 1;
like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/';
ok my $gunzip = new IO::Uncompress::Gunzip \$x,
-Strict => 0;
my $hdr = $gunzip->getHeaderInfo() ;
is $hdr->{Name}, "fred\x02";
}
{
title "Header Corruption - Null Chars in Name";
my $x;
eval { new IO::Compress::Gzip \$x, -Name => "\x00" };
like $@, mkErr('Null Character found in Name');
like $GzipError, '/Null Character found in Name/';
eval { new IO::Compress::Gzip \$x, -Name => "abc\x00" };
like $@, mkErr('Null Character found in Name');
like $GzipError, '/Null Character found in Name/';
ok my $gz = new IO::Compress::Gzip \$x,
-Strict => 0,
-Name => "abc\x00de" ;
ok $gz->close() ;
ok my $gunzip = new IO::Uncompress::Gunzip \$x,
-Strict => 0;
my $hdr = $gunzip->getHeaderInfo() ;
is $hdr->{Name}, "abc";
}
{
title "Header Corruption - Create Comment with Illegal Chars";
my $x;
eval { new IO::Compress::Gzip \$x, -Comment => "fred\x02" };
like $@, mkErr('Non ISO 8859-1 Character found in Comment');
like $GzipError, '/Non ISO 8859-1 Character found in Comment/';
ok my $gz = new IO::Compress::Gzip \$x,
-Strict => 0,
-Comment => "fred\x02" ;
ok $gz->close();
ok ! new IO::Uncompress::Gunzip \$x, Strict => 1,
-Transparent => 0;
like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/';
ok my $gunzip = new IO::Uncompress::Gunzip \$x, Strict => 0;
my $hdr = $gunzip->getHeaderInfo() ;
is $hdr->{Comment}, "fred\x02";
}
{
title "Header Corruption - Null Char in Comment";
my $x;
eval { new IO::Compress::Gzip \$x, -Comment => "\x00" };
like $@, mkErr('Null Character found in Comment');
like $GzipError, '/Null Character found in Comment/';
eval { new IO::Compress::Gzip \$x, -Comment => "abc\x00" } ;
like $@, mkErr('Null Character found in Comment');
like $GzipError, '/Null Character found in Comment/';
ok my $gz = new IO::Compress::Gzip \$x,
-Strict => 0,
-Comment => "abc\x00de" ;
ok $gz->close() ;
ok my $gunzip = new IO::Uncompress::Gunzip \$x,
-Strict => 0;
my $hdr = $gunzip->getHeaderInfo() ;
is $hdr->{Comment}, "abc";
}
for my $index ( GZIP_MIN_HEADER_SIZE + 1 .. GZIP_MIN_HEADER_SIZE + GZIP_FEXTRA_HEADER_SIZE + 1)
{
title "Header Corruption - Truncated in Extra";
my $string = <<EOM;
some text
EOM
my $truncated ;
ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1, Strict => 0,
-ExtraField => "hello" x 10 ;
ok $x->write($string) ;
ok $x->close ;
substr($truncated, $index) = '' ;
#my $lex = new LexFile my $name ;
#writeFile($name, $truncated) ;
#my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0;
my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0;
ok ! $g
or print "# $g\n" ;
like($GunzipError, '/^Header Error: Truncated in FEXTRA/');
}
my $Name = "fred" ;
my $truncated ;
for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Name) -1)
{
title "Header Corruption - Truncated in Name";
my $string = <<EOM;
some text
EOM
my $truncated ;
ok my $x = new IO::Compress::Gzip \$truncated, -Name => $Name;
ok $x->write($string) ;
ok $x->close ;
substr($truncated, $index) = '' ;
my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0;
ok ! $g
or print "# $g\n" ;
like $GunzipError, '/^Header Error: Truncated in FNAME Section/';
}
my $Comment = "comment" ;
for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + length($Comment) -1)
{
title "Header Corruption - Truncated in Comment";
my $string = <<EOM;
some text
EOM
my $truncated ;
ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment;
ok $x->write($string) ;
ok $x->close ;
substr($truncated, $index) = '' ;
#my $lex = new LexFile my $name ;
#writeFile($name, $truncated) ;
#my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0;
my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0;
ok ! $g
or print "# $g\n" ;
like $GunzipError, '/^Header Error: Truncated in FCOMMENT Section/';
}
for my $index ( GZIP_MIN_HEADER_SIZE .. GZIP_MIN_HEADER_SIZE + GZIP_FHCRC_SIZE -1)
{
title "Header Corruption - Truncated in CRC";
my $string = <<EOM;
some text
EOM
my $truncated ;
ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1;
ok $x->write($string) ;
ok $x->close ;
substr($truncated, $index) = '' ;
my $lex = new LexFile my $name ;
writeFile($name, $truncated) ;
my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0;
#my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0;
ok ! $g
or print "# $g\n" ;
like $GunzipError, '/^Header Error: Truncated in FHCRC Section/';
}
{
# Trailer Corruption tests
my $string = <<EOM;
some text
EOM
$string = $string x 1000;
my $good ;
{
ok my $x = new IO::Compress::Gzip \$good ;
ok $x->write($string) ;
ok $x->close ;
}
writeFile($name, $good) ;
ok my $gunz = new IO::Uncompress::Gunzip $name,
-Append => 1,
-Strict => 1;
my $uncomp ;
1 while $gunz->read($uncomp) > 0 ;
ok $gunz->close() ;
ok $uncomp eq $string
or print "# got [$uncomp] wanted [$string]\n";;
foreach my $trim (-8 .. -1)
{
my $got = $trim + 8 ;
title "Trailer Corruption - Trailer truncated to $got bytes" ;
my $buffer = $good ;
my $expected_trailing = substr($good, -8, 8) ;
substr($expected_trailing, $trim) = '';
substr($buffer, $trim) = '';
writeFile($name, $buffer) ;
foreach my $strict (0, 1)
{
ok my $gunz = new IO::Uncompress::Gunzip $name, Append => 1, -Strict => $strict ;
my $uncomp ;
my $status = 1;
$status = $gunz->read($uncomp) while $status > 0;
if ($strict)
{
cmp_ok $status, '<', 0 ;
like $GunzipError, "/Trailer Error: trailer truncated. Expected 8 bytes, got $got/";
}
else
{
is $status, 0, "status 0";
ok ! $GunzipError, "no error"
or diag "$GunzipError";
my $expected = substr($buffer, - $got);
is $gunz->trailingData(), $expected_trailing, "trailing data";
}
ok $gunz->eof() ;
ok $uncomp eq $string;
ok $gunz->close ;
}
}
{
title "Trailer Corruption - Length Wrong, CRC Correct" ;
my $buffer = $good ;
my $actual_len = unpack("V", substr($buffer, -4, 4));
substr($buffer, -4, 4) = pack('V', $actual_len + 1);
writeFile($name, $buffer) ;
foreach my $strict (0, 1)
{
ok my $gunz = new IO::Uncompress::Gunzip $name,
Append => 1,
-Strict => $strict ;
my $uncomp ;
my $status = 1;
$status = $gunz->read($uncomp) while $status > 0;
if ($strict)
{
cmp_ok $status, '<', 0 ;
my $got_len = $actual_len + 1;
like $GunzipError, "/Trailer Error: ISIZE mismatch. Got $got_len, expected $actual_len/";
}
else
{
is $status, 0;
ok ! $GunzipError ;
#is $gunz->trailingData(), substr($buffer, - $got) ;
}
ok ! $gunz->trailingData() ;
ok $gunz->eof() ;
ok $uncomp eq $string;
ok $gunz->close ;
}
}
{
title "Trailer Corruption - Length Correct, CRC Wrong" ;
my $buffer = $good ;
my $actual_crc = unpack("V", substr($buffer, -8, 4));
substr($buffer, -8, 4) = pack('V', $actual_crc+1);
writeFile($name, $buffer) ;
foreach my $strict (0, 1)
{
ok my $gunz = new IO::Uncompress::Gunzip $name,
-Append => 1,
-Strict => $strict ;
my $uncomp ;
my $status = 1;
$status = $gunz->read($uncomp) while $status > 0;
if ($strict)
{
cmp_ok $status, '<', 0 ;
like $GunzipError, '/Trailer Error: CRC mismatch/';
}
else
{
is $status, 0;
ok ! $GunzipError ;
}
ok ! $gunz->trailingData() ;
ok $gunz->eof() ;
ok $uncomp eq $string;
ok $gunz->close ;
}
}
{
title "Trailer Corruption - Length Wrong, CRC Wrong" ;
my $buffer = $good ;
my $actual_len = unpack("V", substr($buffer, -4, 4));
my $actual_crc = unpack("V", substr($buffer, -8, 4));
substr($buffer, -4, 4) = pack('V', $actual_len+1);
substr($buffer, -8, 4) = pack('V', $actual_crc+1);
writeFile($name, $buffer) ;
foreach my $strict (0, 1)
{
ok my $gunz = new IO::Uncompress::Gunzip $name,
-Append => 1,
-Strict => $strict ;
my $uncomp ;
my $status = 1;
$status = $gunz->read($uncomp) while $status > 0;
if ($strict)
{
cmp_ok $status, '<', 0 ;
like $GunzipError, '/Trailer Error: CRC mismatch/';
}
else
{
is $status, 0;
ok ! $GunzipError ;
}
ok $gunz->eof() ;
ok $uncomp eq $string;
ok $gunz->close ;
}
}
{
# RT #72329
my $error = 'Error with ExtraField Parameter: ' .
'SubField ID not two chars long' ;
my $buffer ;
my $x ;
eval { $x = new IO::Compress::Gzip \$buffer,
-ExtraField => [ at => 'mouse', bad => 'dog'] ;
};
like $@, mkErr("$error");
like $GzipError, "/$error/";
ok ! $x ;
}
}