03zlib-v1.t

source of perl for linux application,

    # create a deflate stream with flush points

    my $hello = "I am a HAL 9000 computer" x 2001 ;
    my $goodbye = "Will I dream?" x 2010;
    my ($err, $answer, $X, $status, $Answer);
     
    ok (($x, $err) = deflateInit() ) ;
    ok $x ;
    ok $err == Z_OK ;
     
    ($Answer, $status) = $x->deflate($hello) ;
    ok $status == Z_OK ;
    
    # create a flush point
    ok ((($X, $status) = $x->flush(Z_FULL_FLUSH))[1] == Z_OK ) ;
    $Answer .= $X ;
     
    ($X, $status) = $x->deflate($goodbye) ;
    ok $status == Z_OK ;
    $Answer .= $X ;
    
    ok ((($X, $status) = $x->flush())[1] == Z_OK ) ;
    $Answer .= $X ;
     
    my ($first, @Answer) = split('', $Answer) ;
     
    my $k;
    ok (($k, $err) = inflateInit()) ;
    ok $k ;
    ok $err == Z_OK ;
     
    ($Z, $status) = $k->inflate($first) ;
    ok $status == Z_OK ;

    # skip to the first flush point.
    while (@Answer)
    {
        my $byte = shift @Answer;
        $status = $k->inflateSync($byte) ;
        last unless $status == Z_DATA_ERROR;
     
    }

    ok $status == Z_OK;
     
    my $GOT = '';
    my $Z = '';
    foreach (@Answer)
    {
        my $Z = '';
        ($Z, $status) = $k->inflate($_) ;
        $GOT .= $Z if defined $Z ;
        # print "x $status\n";
        last if $status == Z_STREAM_END or $status != Z_OK ;
     
    }
     
    # zlib 1.0.9 returns Z_STREAM_END here, all others return Z_DATA_ERROR
    ok $status == Z_DATA_ERROR || $status == Z_STREAM_END ;
    ok $GOT eq $goodbye ;


    # Check inflateSync leaves good data in buffer
    $Answer =~ /^(.)(.*)$/ ;
    my ($initial, $rest) = ($1, $2);

    
    ok (($k, $err) = inflateInit()) ;
    ok $k ;
    ok $err == Z_OK ;
     
    ($Z, $status) = $k->inflate($initial) ;
    ok $status == Z_OK ;

    $status = $k->inflateSync($rest) ;
    ok $status == Z_OK;
     
    ($GOT, $status) = $k->inflate($rest) ;
     
    ok $status == Z_DATA_ERROR ;
    ok $Z . $GOT eq $goodbye ;
}

{
    # deflateParams

    my $hello = "I am a HAL 9000 computer" x 2001 ;
    my $goodbye = "Will I dream?" x 2010;
    my ($input, $err, $answer, $X, $status, $Answer);
     
    ok (($x, $err) = deflateInit(-Level    => Z_BEST_COMPRESSION,
                                     -Strategy => Z_DEFAULT_STRATEGY) ) ;
    ok $x ;
    ok $err == Z_OK ;

    ok $x->get_Level()    == Z_BEST_COMPRESSION;
    ok $x->get_Strategy() == Z_DEFAULT_STRATEGY;
     
    ($Answer, $status) = $x->deflate($hello) ;
    ok $status == Z_OK ;
    $input .= $hello;
    
    # error cases
    eval { $x->deflateParams() };
    #like $@, mkErr("^Compress::Raw::Zlib::deflateParams needs Level and/or Strategy");
    like $@, "/^Compress::Raw::Zlib::deflateParams needs Level and/or Strategy/";

    eval { $x->deflateParams(-Joe => 3) };
    like $@, "/^Compress::Raw::Zlib::deflateStream::deflateParams: unknown key value/";
    #like $@, mkErr("^Compress::Raw::Zlib::deflateStream::deflateParams: unknown key value(s) Joe");
    #ok $@ =~ /^Compress::Zlib::deflateStream::deflateParams: unknown key value\(s\) Joe at/
    #    or print "# $@\n" ;

    ok $x->get_Level()    == Z_BEST_COMPRESSION;
    ok $x->get_Strategy() == Z_DEFAULT_STRATEGY;
     
    # change both Level & Strategy
    $status = $x->deflateParams(-Level => Z_BEST_SPEED, -Strategy => Z_HUFFMAN_ONLY) ;
    ok $status == Z_OK ;
    
    ok $x->get_Level()    == Z_BEST_SPEED;
    ok $x->get_Strategy() == Z_HUFFMAN_ONLY;
     
    ($X, $status) = $x->deflate($goodbye) ;
    ok $status == Z_OK ;
    $Answer .= $X ;
    $input .= $goodbye;
    
    # change only Level 
    $status = $x->deflateParams(-Level => Z_NO_COMPRESSION) ;
    ok $status == Z_OK ;
    
    ok $x->get_Level()    == Z_NO_COMPRESSION;
    ok $x->get_Strategy() == Z_HUFFMAN_ONLY;
     
    ($X, $status) = $x->deflate($goodbye) ;
    ok $status == Z_OK ;
    $Answer .= $X ;
    $input .= $goodbye;
    
    # change only Strategy
    $status = $x->deflateParams(-Strategy => Z_FILTERED) ;
    ok $status == Z_OK ;
    
    ok $x->get_Level()    == Z_NO_COMPRESSION;
    ok $x->get_Strategy() == Z_FILTERED;
     
    ($X, $status) = $x->deflate($goodbye) ;
    ok $status == Z_OK ;
    $Answer .= $X ;
    $input .= $goodbye;
    
    ok ((($X, $status) = $x->flush())[1] == Z_OK ) ;
    $Answer .= $X ;
     
    my ($first, @Answer) = split('', $Answer) ;
     
    my $k;
    ok (($k, $err) = inflateInit()) ;
    ok $k ;
    ok $err == Z_OK ;
     
    ($Z, $status) = $k->inflate($Answer) ;

    ok $status == Z_STREAM_END 
        or print "# status $status\n";
    ok $Z  eq $input ;
}

{
    # error cases

    eval { deflateInit(-Level) };
    like $@, '/^Compress::Zlib::deflateInit: Expected even number of parameters, got 1/';

    eval { inflateInit(-Level) };
    like $@, '/^Compress::Zlib::inflateInit: Expected even number of parameters, got 1/';

    eval { deflateInit(-Joe => 1) };
    ok $@ =~ /^Compress::Zlib::deflateInit: unknown key value\(s\) Joe at/;

    eval { inflateInit(-Joe => 1) };
    ok $@ =~ /^Compress::Zlib::inflateInit: unknown key value\(s\) Joe at/;

    eval { deflateInit(-Bufsize => 0) };
    ok $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/;

    eval { inflateInit(-Bufsize => 0) };
    ok $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/;

    eval { deflateInit(-Bufsize => -1) };
    #ok $@ =~ /^.*?: Bufsize must be >= 1, you specified -1 at/;
    ok $@ =~ /^Compress::Zlib::deflateInit: Parameter 'Bufsize' must be an unsigned int, got '-1'/;

    eval { inflateInit(-Bufsize => -1) };
    ok $@ =~ /^Compress::Zlib::inflateInit: Parameter 'Bufsize' must be an unsigned int, got '-1'/;

    eval { deflateInit(-Bufsize => "xxx") };
    ok $@ =~ /^Compress::Zlib::deflateInit: Parameter 'Bufsize' must be an unsigned int, got 'xxx'/;

    eval { inflateInit(-Bufsize => "xxx") };
    ok $@ =~ /^Compress::Zlib::inflateInit: Parameter 'Bufsize' must be an unsigned int, got 'xxx'/;

    eval { gzopen([], 0) ; }  ;
    ok $@ =~ /^gzopen: file parameter is not a filehandle or filename at/
	or print "# $@\n" ;

#    my $x = Symbol::gensym() ;
#    eval { gzopen($x, 0) ; }  ;
#    ok $@ =~ /^gzopen: file parameter is not a filehandle or filename at/
#	or print "# $@\n" ;

}

if ($] >= 5.005)
{
    # test inflate with a substr

    ok my $x = deflateInit() ;
     
    ok ((my ($X, $status) = $x->deflate($contents))[1] == Z_OK) ;
    
    my $Y = $X ;

     
     
    ok ((($X, $status) = $x->flush() )[1] == Z_OK ) ;
    $Y .= $X ;
     
    my $append = "Appended" ;
    $Y .= $append ;
     
    ok $k = inflateInit() ;
     
    #($Z, $status) = $k->inflate(substr($Y, 0, -1)) ;
    ($Z, $status) = $k->inflate(substr($Y, 0)) ;
     
    ok $status == Z_STREAM_END ;
    ok $contents eq $Z ;
    is $Y, $append;
    
}

if ($] >= 5.005)
{
    # deflate/inflate in scalar context

    ok my $x = deflateInit() ;
     
    my $X = $x->deflate($contents);
    
    my $Y = $X ;

     
     
    $X = $x->flush();
    $Y .= $X ;
     
    my $append = "Appended" ;
    $Y .= $append ;
     
    ok $k = inflateInit() ;
     
    $Z = $k->inflate(substr($Y, 0, -1)) ;
    #$Z = $k->inflate(substr($Y, 0)) ;
     
    ok $contents eq $Z ;
    is $Y, $append;
    
}

{
    title 'CRC32' ;

    # CRC32 of this data should have the high bit set
    # value in ascii is ZgRNtjgSUW
    my $data = "\x5a\x67\x52\x4e\x74\x6a\x67\x53\x55\x57"; 
    my $expected_crc = 0xCF707A2B ; # 3480255019 

    my $crc = crc32($data) ;
    is $crc, $expected_crc;
}

{
    title 'Adler32' ;

    # adler of this data should have the high bit set
    # value in ascii is lpscOVsAJiUfNComkOfWYBcPhHZ[bT
    my $data = "\x6c\x70\x73\x63\x4f\x56\x73\x41\x4a\x69\x55\x66" .
               "\x4e\x43\x6f\x6d\x6b\x4f\x66\x57\x59\x42\x63\x50" .
               "\x68\x48\x5a\x5b\x62\x54";
    my $expected_crc = 0xAAD60AC7 ; # 2866154183 
    my $crc = adler32($data) ;
    is $crc, $expected_crc;
}

{
    # memGunzip - input > 4K

    my $contents = '' ;
    foreach (1 .. 20000)
      { $contents .= chr int rand 256 }

    ok my $compressed = Compress::Zlib::memGzip(\$contents) ;

    ok length $compressed > 4096 ;
    ok my $out = Compress::Zlib::memGunzip(\$compressed) ;
     
    ok $contents eq $out ;
    is length $out, length $contents ;

    
}


{
    # memGunzip Header Corruption Tests

    my $string = <<EOM;
some text
EOM

    my $good ;
    ok my $x = new IO::Compress::Gzip \$good, Append => 1, -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 ! Compress::Zlib::memGunzip(\$buffer) ;
    }

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

        ok ! Compress::Zlib::memGunzip(\$buffer) ;
    }

    {
        title "Header Corruption - CM not 8";
        my $buffer = $good ;
        substr($buffer, 2, 1) = 'x' ;

        ok ! Compress::Zlib::memGunzip(\$buffer) ;
    }

    {
        title "Header Corruption - Use of Reserved Flags";
        my $buffer = $good ;
        substr($buffer, 3, 1) = "\xff";

        ok ! Compress::Zlib::memGunzip(\$buffer) ;
    }

}

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, Append => 1, -HeaderCRC => 1, Strict => 0,
				-ExtraField => "hello" x 10  ;
    ok  $x->write($string) ;
    ok  $x->close ;

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

    ok ! Compress::Zlib::memGunzip(\$truncated) ;


}

my $Name = "fred" ;
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, Append => 1, -Name => $Name;
    ok  $x->write($string) ;
    ok  $x->close ;

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

    ok ! Compress::Zlib::memGunzip(\$truncated) ;
}

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) = '' ;
    ok ! Compress::Zlib::memGunzip(\$truncated) ;
}

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) = '' ;

    ok ! Compress::Zlib::memGunzip(\$truncated) ;
}

{
    title "memGunzip can cope with a gzip header with all possible fields";
    my $string = <<EOM;
some text
EOM

    my $buffer ;
    ok  my $x = new IO::Compress::Gzip \$buffer, 
                             -Append     => 1,
                             -Strict     => 0,
                             -HeaderCRC  => 1,
                             -Name       => "Fred",
                             -ExtraField => "Extra",
                             -Comment    => 'Comment';
    ok  $x->write($string) ;
    ok  $x->close ;

    ok defined $buffer ;

    ok my $got = Compress::Zlib::memGunzip($buffer) 
        or diag "gzerrno is $gzerrno" ;
    is $got, $string ;
}


{
    # Trailer Corruption tests

    my $string = <<EOM;
some text
EOM

    my $good ;
    ok  my $x = new IO::Compress::Gzip \$good, Append => 1 ;
    ok  $x->write($string) ;
    ok  $x->close ;

    foreach my $trim (-8 .. -1)
    {
        my $got = $trim + 8 ;
        title "Trailer Corruption - Trailer truncated to $got bytes" ;
        my $buffer = $good ;

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

        ok my $u = Compress::Zlib::memGunzip(\$buffer) ;
        ok $u eq $string;

    }

    {
        title "Trailer Corruption - Length Wrong, CRC Correct" ;
        my $buffer = $good ;
        substr($buffer, -4, 4) = pack('V', 1234);

        ok ! Compress::Zlib::memGunzip(\$buffer) ;
    }

    {
        title "Trailer Corruption - Length Wrong, CRC Wrong" ;
        my $buffer = $good ;
        substr($buffer, -4, 4) = pack('V', 1234);
        substr($buffer, -8, 4) = pack('V', 1234);

        ok ! Compress::Zlib::memGunzip(\$buffer) ;

    }
}


sub slurp
{
    my $name = shift ;

    my $input;
    my $fil = gzopen($name, "rb") ;
    ok $fil , "opened $name";
    cmp_ok $fil->gzread($input, 50000), ">", 0, "read more than zero bytes";
    ok ! $fil->gzclose(), "closed ok";

    return $input;
}

sub trickle
{
    my $name = shift ;

    my $got;
    my $input;
    $fil = gzopen($name, "rb") ;
    ok $fil, "opened ok";
    while ($fil->gzread($input, 50000) > 0)
    {
        $got .= $input;
        $input = '';
    }
    ok ! $fil->gzclose(), "closed ok";

    return $got;

    return $input;
}

{

    title "Append & MultiStream Tests";
    # rt.24041

    my $lex = new LexFile my $name ;
    my $data1 = "the is the first";
    my $data2 = "and this is the second";
    my $trailing = "some trailing data";

    my $fil;

    title "One file";
    $fil = gzopen($name, "wb") ;
    ok $fil, "opened first file"; 
    is $fil->gzwrite($data1), length $data1, "write data1" ;
    ok ! $fil->gzclose(), "Closed";

    is slurp($name), $data1, "got expected data from slurp";
    is trickle($name), $data1, "got expected data from trickle";

    title "Two files";
    $fil = gzopen($name, "ab") ;
    ok $fil, "opened second file"; 
    is $fil->gzwrite($data2), length $data2, "write data2" ;
    ok ! $fil->gzclose(), "Closed";

    is slurp($name), $data1 . $data2, "got expected data from slurp";
    is trickle($name), $data1 . $data2, "got expected data from trickle";

    title "Trailing Data";
    open F, ">>$name";
    print F $trailing;
    close F;

    is slurp($name), $data1 . $data2 . $trailing, "got expected data from slurp" ;
    is trickle($name), $data1 . $data2 . $trailing, "got expected data from trickle" ;
}

{
    title "gzclose & gzflush return codes";
    # rt.29215

    my $lex = new LexFile my $name ;
    my $data1 = "the is some text";
    my $status;

    $fil = gzopen($name, "wb") ;
    ok $fil, "opened first file"; 
    is $fil->gzwrite($data1), length $data1, "write data1" ;
    $status = $fil->gzflush(0xfff);
    ok   $status, "flush not ok" ;
    is $status, Z_STREAM_ERROR;
    ok ! $fil->gzflush(), "flush ok" ;
    ok ! $fil->gzclose(), "Closed";
}