005defhdr.t

source of perl for linux application,

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 => 595 + $extra ;

    use_ok('Compress::Raw::Zlib') ;

    use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
    use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;

    use_ok('IO::Compress::Zlib::Constants');

}


sub ReadHeaderInfo
{
    my $string = shift || '' ;
    my %opts = @_ ;

    my $buffer ;
    ok my $def = new IO::Compress::Deflate \$buffer, %opts ;
    is $def->write($string), length($string) ;
    ok $def->close ;
    #print "ReadHeaderInfo\n"; hexDump(\$buffer);

    ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1  ;
    my $uncomp ;
    #ok $inf->read($uncomp) ;
    my $actual = 0 ;
    my $status = 1 ;
    while (($status = $inf->read($uncomp)) > 0) {
        $actual += $status ;
    }

    is $actual, length($string) ;
    is $uncomp, $string;
    ok ! $inf->error() ;
    ok $inf->eof() ;
    ok my $hdr = $inf->getHeaderInfo();
    ok $inf->close ;

    return $hdr ;
}

sub ReadHeaderInfoZlib
{
    my $string = shift || '' ;
    my %opts = @_ ;

    my $buffer ;
    ok my $def = new Compress::Raw::Zlib::Deflate AppendOutput => 1, %opts ;
    cmp_ok $def->deflate($string, $buffer), '==',  Z_OK;
    cmp_ok $def->flush($buffer), '==', Z_OK;
    #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer);
    
    ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1  ;
    my $uncomp ;
    #ok $inf->read($uncomp) ;
    my $actual = 0 ;
    my $status = 1 ;
    while (($status = $inf->read($uncomp)) > 0) {
        $actual += $status ;
    }

    is $actual, length($string) ;
    is $uncomp, $string;
    ok ! $inf->error() ;
    ok $inf->eof() ;
    ok my $hdr = $inf->getHeaderInfo();
    ok $inf->close ;

    return $hdr ;
}

sub printHeaderInfo
{
    my $buffer = shift ;
    my $inf = new IO::Uncompress::Inflate \$buffer  ;
    my $hdr = $inf->getHeaderInfo();

    no warnings 'uninitialized' ;
    while (my ($k, $v) = each %$hdr) {
        print "  $k -> $v\n" ;
    }
}


# Check the Deflate Header Parameters
#========================================

my $lex = new LexFile my $name ;

{
    title "Check default header settings" ;

    my $string = <<EOM;
some text
EOM

    my $hdr = ReadHeaderInfo($string);

    is $hdr->{CM}, 8, "  CM is 8";
    is $hdr->{FDICT}, 0, "  FDICT is 0";

}

{
    title "Check user-defined header settings match zlib" ;

    my $string = <<EOM;
some text
EOM

    my @tests = (
        [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
        [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
        [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
        [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
        [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
        [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
        [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ],
        [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
        [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
        [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],

        [ {-Level => Z_NO_COMPRESSION  }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
        [ {-Level => Z_BEST_SPEED      }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
        [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
        [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ],

        [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
        [ {-Strategy => Z_HUFFMAN_ONLY,
           -Level    => 3             }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
    );

    foreach my $test (@tests)
    {
        my $opts = $test->[0] ;
        my $expect = $test->[1] ;

        my @title ;
        while (my ($k, $v) = each %$opts)
        {
            push @title, "$k => $v";
        }
        title " Set @title";

        my $hdr = ReadHeaderInfo($string, %$opts);

        my $hdr1 = ReadHeaderInfoZlib($string, %$opts);

        is $hdr->{CM},     8, "  CM is 8";
        is $hdr->{CINFO},  7, "  CINFO is 7";
        is $hdr->{FDICT},  0, "  FDICT is 0";

        while (my ($k, $v) = each %$expect)
        {
            if (ZLIB_VERNUM >= 0x1220)
              { is $hdr->{$k}, $v, "  $k is $v" }
            else
              { ok 1, "  Skip test for $k" }
        }

        is $hdr->{CM},     $hdr1->{CM},     "  CM matches";
        is $hdr->{CINFO},  $hdr1->{CINFO},  "  CINFO matches";
        is $hdr->{FDICT},  $hdr1->{FDICT},  "  FDICT matches";
        is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, "  FLEVEL matches";
        is $hdr->{FCHECK}, $hdr1->{FCHECK}, "  FCHECK matches";
    }


}

{
    title "No compressed data at all";

    my $hdr = ReadHeaderInfo("");

    is $hdr->{CM}, 8, "  CM is 8";
    is $hdr->{FDICT}, 0, "  FDICT is 0";

    ok defined $hdr->{ADLER32}, "  ADLER32 is defined" ;
    is $hdr->{ADLER32}, 1, "  ADLER32 is 1";
}

{
    # Header Corruption Tests

    my $string = <<EOM;
some text
EOM

    my $good ;
    ok my $x = new IO::Compress::Deflate \$good ;
    ok $x->write($string) ;
    ok $x->close ;

    {
        title "Header Corruption - FCHECK failure - 1st byte wrong";
        my $buffer = $good ;
        substr($buffer, 0, 1) = "\x00" ;

        ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
        like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/',
            "CRC mismatch";
    }

    {
        title "Header Corruption - FCHECK failure - 2nd byte wrong";
        my $buffer = $good ;
        substr($buffer, 1, 1) = "\x00" ;

        ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
        like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/',
            "CRC mismatch";
    }


    sub mkZlibHdr
    {
        my $method = shift ;
        my $cinfo  = shift ;
        my $fdict  = shift ;
        my $level  = shift ;

        my $cmf  = ($method & 0x0F) ;
           $cmf |= (($cinfo  & 0x0F) << 4) ;
        my $flg  = (($level & 0x03) << 6) ;
           $flg |= (($fdict & 0x01) << 5) ;
        my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ;
        $flg |= $fcheck ;
        #print "check $fcheck\n";

        return pack("CC", $cmf, $flg) ;
    }

    {
        title "Header Corruption - CM not 8";
        my $buffer = $good ;
        my $header = mkZlibHdr(3, 6, 0, 3);

        substr($buffer, 0, 2) = $header;

        my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
        ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
        like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/',
            "  Not Deflate";
    }

}

{
    # Trailer Corruption tests

    my $string = <<EOM;
some text
EOM

    my $good ;
    ok my $x = new IO::Compress::Deflate \$good ;
    ok $x->write($string) ;
    ok $x->close ;

    foreach my $trim (-4 .. -1)
    {
        my $got = $trim + 4 ;
        foreach my $s (0, 1)
        {
            title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ;
            my $buffer = $good ;
            my $expected_trailing = substr($good, -4, 4) ;
            substr($expected_trailing, $trim) = '';

            substr($buffer, $trim) = '';
            writeFile($name, $buffer) ;

            ok my $gunz = new IO::Uncompress::Inflate $name, Strict => $s;
            my $uncomp ;
            if ($s)
            {
                ok $gunz->read($uncomp) < 0 ;
                like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/",
                    "Trailer Error";
            }
            else
            {
                is $gunz->read($uncomp), length $string ;
            }
            ok $gunz->eof() ;
            ok $uncomp eq $string;
            ok $gunz->close ;
        }

    }

    {
        title "Trailer Corruption - CRC Wrong, strict" ;
        my $buffer = $good ;
        my $crc = unpack("N", substr($buffer, -4, 4));
        substr($buffer, -4, 4) = pack('N', $crc+1);
        writeFile($name, $buffer) ;

        ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 1;
        my $uncomp ;
        ok $gunz->read($uncomp) < 0 ;
        like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/',
            "Trailer Error: CRC mismatch";
        ok $gunz->eof() ;
        ok ! $gunz->trailingData() ;
        ok $uncomp eq $string;
        ok $gunz->close ;
    }

    {
        title "Trailer Corruption - CRC Wrong, no strict" ;
        my $buffer = $good ;
        my $crc = unpack("N", substr($buffer, -4, 4));
        substr($buffer, -4, 4) = pack('N', $crc+1);
        writeFile($name, $buffer) ;

        ok my $gunz = new IO::Uncompress::Inflate $name, Strict => 0;
        my $uncomp ;
        ok $gunz->read($uncomp) >= 0  ;
        ok $gunz->eof() ;
        ok ! $gunz->trailingData() ;
        ok $uncomp eq $string;
        ok $gunz->close ;
    }
}