xref: /openbsd/gnu/usr.bin/perl/cpan/IO-Compress/t/004gziphdr.t (revision 5486feef)

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 ;  Test::NoWarnings->import; 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 = LexFile->new( 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 { IO::Compress::Gzip->new( $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 ! IO::Compress::Gzip->new($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 = IO::Compress::Gzip->new( $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 = IO::Uncompress::Gunzip->new( $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 = IO::Compress::Gzip->new( \$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 = IO::Compress::Gzip->new( \$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 = IO::Compress::Gzip->new( \$buffer,
                                           ExtraField => $input,
                                           Strict     => 0 )
                or diag "GzipError is $GzipError" ;
            my $string = "abcd" ;
            $x->write($string) ;
            $x->close ;
            is anyUncompress(\$buffer), $string ;

            $x = IO::Uncompress::Gunzip->new( \$buffer,
                                       Strict      => 0,
                                       Transparent => 0,
                                       ParseExtra  => $check );
            if ($check) {
                ok ! $x ;
                like $GunzipError, "/^$gunzip_error/";
            }
            else {
                ok $x ;
            }

        }
    }
}


{
    title 'Check Minimal';

    ok my $x = IO::Compress::Gzip->new( $name, -Minimal => 1 );
    my $string = "abcd" ;
    ok $x->write($string) ;
    ok $x->close ;
    #is GZreadFile($name), $string ;

    ok $x = IO::Uncompress::Gunzip->new( $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 = IO::Compress::Gzip->new( $name, -Minimal => 1 );
    isa_ok $x, "IO::Compress::Gzip";
    ok $x->close, "closed" ;

    ok $x = IO::Uncompress::Gunzip->new( $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 = IO::Compress::Gzip->new( \$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 ! IO::Uncompress::Gunzip->new( \$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 ! IO::Uncompress::Gunzip->new( \$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 ! IO::Uncompress::Gunzip->new( \$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 ! IO::Uncompress::Gunzip->new( \$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 ! IO::Uncompress::Gunzip->new( \$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 = IO::Compress::Gzip->new(\$x, ExtraField => $store, Strict => 0) ;
        ok $z,  "Created IO::Compress::Gzip object" ;
    }
    my $gunz = IO::Uncompress::Gunzip->new( \$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 { IO::Compress::Gzip->new(\$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 { IO::Compress::Gzip->new( \$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 = IO::Compress::Gzip->new( \$x,
		                      -Strict => 0,
		                      -Name => "fred\x02" );
    ok $gz->close();

    ok ! IO::Uncompress::Gunzip->new( \$x,
                        -Transparent => 0,
                        -Strict => 1 );

    like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/';
    ok my $gunzip = IO::Uncompress::Gunzip->new( \$x,
                                   -Strict => 0 );

    my $hdr = $gunzip->getHeaderInfo() ;

    is $hdr->{Name}, "fred\x02";

}

{
    title "Header Corruption - Null Chars in Name";
    my $x;
    eval { IO::Compress::Gzip->new( \$x, -Name => "\x00" ) };
    like $@, mkErr('Null Character found in Name');
    like $GzipError, '/Null Character found in Name/';

    eval { IO::Compress::Gzip->new( \$x, -Name => "abc\x00" ) };
    like $@, mkErr('Null Character found in Name');
    like $GzipError, '/Null Character found in Name/';

    ok my $gz = IO::Compress::Gzip->new( \$x,
		                     -Strict  => 0,
		                     -Name => "abc\x00de" );
    ok $gz->close() ;
    ok my $gunzip = IO::Uncompress::Gunzip->new( \$x,
                                   -Strict => 0 );

    my $hdr = $gunzip->getHeaderInfo() ;

    is $hdr->{Name}, "abc";

}

{
    title "Header Corruption - Create Comment with Illegal Chars";

    my $x;
    eval { IO::Compress::Gzip->new( \$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 = IO::Compress::Gzip->new( \$x,
		                      -Strict => 0,
		                      -Comment => "fred\x02" );
    ok $gz->close();

    ok ! IO::Uncompress::Gunzip->new( \$x, Strict => 1,
                        -Transparent => 0 );

    like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/';
    ok my $gunzip = IO::Uncompress::Gunzip->new( \$x, Strict => 0 );

    my $hdr = $gunzip->getHeaderInfo() ;

    is $hdr->{Comment}, "fred\x02";

}

{
    title "Header Corruption - Null Char in Comment";
    my $x;
    eval { IO::Compress::Gzip->new( \$x, -Comment => "\x00" ) };
    like $@, mkErr('Null Character found in Comment');
    like $GzipError, '/Null Character found in Comment/';

    eval { IO::Compress::Gzip->new( \$x, -Comment => "abc\x00" ) } ;
    like $@, mkErr('Null Character found in Comment');
    like $GzipError, '/Null Character found in Comment/';

    ok my $gz = IO::Compress::Gzip->new( \$x,
		                     -Strict  => 0,
		                     -Comment => "abc\x00de" );
    ok $gz->close() ;
    ok my $gunzip = IO::Uncompress::Gunzip->new( \$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 = IO::Compress::Gzip->new( \$truncated, -HeaderCRC => 1, Strict => 0,
				-ExtraField => "hello" x 10 );
    ok $x->write($string) ;
    ok $x->close ;

    substr($truncated, $index) = '' ;
    #my $lex = LexFile->new( my $name );
    #writeFile($name, $truncated) ;

    #my $g = IO::Uncompress::Gunzip->new( $name, -Transparent => 0 );
    my $g = IO::Uncompress::Gunzip->new( \$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 = IO::Compress::Gzip->new( \$truncated, -Name => $Name );
    ok $x->write($string) ;
    ok $x->close ;

    substr($truncated, $index) = '' ;

    my $g = IO::Uncompress::Gunzip->new( \$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 = IO::Compress::Gzip->new( \$truncated, -Comment => $Comment );
    ok $x->write($string) ;
    ok $x->close ;

    substr($truncated, $index) = '' ;
    #my $lex = LexFile->new( my $name );
    #writeFile($name, $truncated) ;

    #my $g = IO::Uncompress::Gunzip->new( $name, -Transparent => 0 );
    my $g = IO::Uncompress::Gunzip->new( \$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 = IO::Compress::Gzip->new( \$truncated, -HeaderCRC => 1 );
    ok $x->write($string) ;
    ok $x->close ;

    substr($truncated, $index) = '' ;
    my $lex = LexFile->new( my $name );
    writeFile($name, $truncated) ;

    my $g = IO::Uncompress::Gunzip->new( $name, -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 = IO::Compress::Gzip->new( \$good );
        ok $x->write($string) ;
        ok $x->close ;
    }

    writeFile($name, $good) ;
    ok my $gunz = IO::Uncompress::Gunzip->new( $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 = IO::Uncompress::Gunzip->new( $name, Append => 1, -Strict   => $strict );
            my $uncomp ;
            my $status = 1;
            $status = $gunz->read($uncomp) while $status > 0;
            if ($strict)
            {
                cmp_ok $status, '<', 0, "status 0" ;
                like $GunzipError, "/Trailer Error: trailer truncated. Expected 8 bytes, got $got/", "got Trailer Error";
            }
            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 = IO::Uncompress::Gunzip->new( $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 = IO::Uncompress::Gunzip->new( $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 = IO::Uncompress::Gunzip->new( $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 = IO::Compress::Gzip->new( \$buffer,
                -ExtraField  => [ at => 'mouse', bad => 'dog'] );
             };
        like $@, mkErr("$error");
        like $GzipError, "/$error/";
        ok ! $x ;
    }
}