[p5sagit/p5-mst-13.2.git] / ext / Compress / Zlib / t / 11truncate.t

BEGIN {
    if ($ENV{PERL_CORE}) {
	chdir 't' if -d 't';
	@INC = ("../lib", "lib");
    }
}

use lib 't';
use strict;
use warnings;
use bytes;

use Test::More ;
use ZlibTestUtils;

BEGIN {
    # use Test::NoWarnings, if available
    my $extra = 0 ;
    $extra = 1
        if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };

    plan tests => 2374 + $extra;

    use_ok('Compress::Zlib', 2) ;

    use_ok('IO::Compress::Gzip', qw($GzipError)) ;
    use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;

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

    use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
    use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;

}


my $hello = <<EOM ;
hello world
this is a test
some more stuff on this line
ad finally...
EOM

my $blocksize = 10 ;


foreach my $CompressClass ('IO::Compress::Gzip', 'IO::Compress::Deflate')
{
    my $UncompressClass = getInverse($CompressClass);


    my $compressed ;
    my $cc ;
    my $gz ;
    if ($CompressClass eq 'IO::Compress::Gzip') {
        ok( my $x = new IO::Compress::Gzip \$compressed, 
                                 -Name       => "My name",
                                 -Comment    => "a comment",
                                 -ExtraField => ['ab' => "extra"],
                                 -HeaderCRC  => 1); 
        ok $x->write($hello) ;
        ok $x->close ;
        $cc = $compressed ;

        ok($gz = new IO::Uncompress::Gunzip \$cc,
                                -Transparent => 0)
                or diag "$GunzipError";
        my $un;
        ok $gz->read($un) > 0 ;
        ok $gz->close();
        ok $un eq $hello ;
    }
    else {
        ok( my $x = new $CompressClass(\$compressed));
        ok $x->write($hello) ;
        ok $x->close ;
        $cc = $compressed ;

        ok($gz = new $UncompressClass(\$cc,
                                      -Transparent => 0))
                or diag "$GunzipError";
        my $un;
        ok $gz->read($un) > 0 ;
        ok $gz->close();
        ok $un eq $hello ;
    }

                           
    for my $trans ( 0 .. 1)
    {
        title "Testing $CompressClass, Transparent $trans";

        my $info = $gz->getHeaderInfo() ;
        my $header_size = $info->{HeaderLength};
        my $trailer_size = $info->{TrailerLength};
        ok 1, "Compressed size is " . length($compressed) ;
        ok 1, "Header size is $header_size" ;
        ok 1, "Trailer size is $trailer_size" ;

        title "Fingerprint Truncation";
        foreach my $i (1)
        {
            my $lex = new LexFile my $name ;
        
            ok 1, "Length $i" ;
            my $part = substr($compressed, 0, $i);
            writeFile($name, $part);

            my $gz = new $UncompressClass $name,
                                          -BlockSize   => $blocksize,
                                          -Transparent => $trans;
            if ($trans) {
                ok $gz;
                ok ! $gz->error() ;
                my $buff ;
                ok $gz->read($buff) == length($part) ;
                ok $buff eq $part ;
                ok $gz->eof() ;
                $gz->close();
            }
            else {
                ok !$gz;
            }

        }

        title "Header Truncation";
        #
        # Any header corruption past the fingerprint is considered catastrophic
        # so even if Transparent is set, it should still fail
        #
        foreach my $i (2 .. $header_size -1)
        {
            my $lex = new LexFile my $name ;
        
            ok 1, "Length $i" ;
            my $part = substr($compressed, 0, $i);
            writeFile($name, $part);
            ok ! defined new $UncompressClass $name,
                                              -BlockSize   => $blocksize,
                                              -Transparent => $trans;
            #ok $gz->eof() ;
        }
        
        title "Compressed Data Truncation";
        foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size)
        {
        
            my $lex = new LexFile my $name ;
        
            ok 1, "Length $i" ;
            my $part = substr($compressed, 0, $i);
            writeFile($name, $part);
            ok my $gz = new $UncompressClass $name,
                                             -BlockSize   => $blocksize,
                                             -Transparent => $trans;
            my $un ;
            my $status = 0 ;
            $status = $gz->read($un) while $status >= 0 ;
            ok $status < 0 ;
            ok $gz->eof() ;
            ok $gz->error() ;
            $gz->close();
        }
        
        # RawDeflate does not have a trailer
        next if $CompressClass eq 'IO::Compress::RawDeflate' ;

        title "Compressed Trailer Truncation";
        foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 )
        {
            foreach my $lax (0, 1)
            {
                my $lex = new LexFile my $name ;
            
                ok 1, "Length $i, Lax $lax" ;
                my $part = substr($compressed, 0, $i);
                writeFile($name, $part);
                ok my $gz = new $UncompressClass $name,
                                                 -BlockSize   => $blocksize,
                                                 -Strict      => !$lax,
                                                 -Append      => 1,   
                                                 -Transparent => $trans;
                my $un = '';
                my $status = 1 ;
                $status = $gz->read($un) while $status > 0 ;

                if ($lax)
                {
                    is $un, $hello;
                    is $status, 0 
                        or diag "Status $status Error is " . $gz->error() ;
                    ok $gz->eof()
                        or diag "Status $status Error is " . $gz->error() ;
                    ok ! $gz->error() ;
                }
                else
                {
                    ok $status < 0 
                        or diag "Status $status Error is " . $gz->error() ;
                    ok $gz->eof()
                        or diag "Status $status Error is " . $gz->error() ;
                    ok $gz->error() ;
                }
                
                $gz->close();
            }
        }
    }
}


foreach my $CompressClass ( 'IO::Compress::RawDeflate')
{
    my $UncompressClass = getInverse($CompressClass);
    my $Error = getErrorRef($UncompressClass);

    my $compressed ;
        ok( my $x = new IO::Compress::RawDeflate \$compressed);
        ok $x->write($hello) ;
        ok $x->close ;

                           
    my $cc = $compressed ;

    my $gz ;
    ok($gz = new $UncompressClass(\$cc,
                                  -Transparent => 0))
            or diag "$$Error\n";
    my $un;
    ok $gz->read($un) > 0 ;
    ok $gz->close();
    ok $un eq $hello ;
    
    for my $trans (0 .. 1)
    {
        title "Testing $CompressClass, Transparent = $trans";

        my $info = $gz->getHeaderInfo() ;
        my $header_size = $info->{HeaderLength};
        my $trailer_size = $info->{TrailerLength};
        ok 1, "Compressed size is " . length($compressed) ;
        ok 1, "Header size is $header_size" ;
        ok 1, "Trailer size is $trailer_size" ;

        
        title "Compressed Data Truncation";
        foreach my $i (0 .. $blocksize)
        {
        
            my $lex = new LexFile my $name ;
        
            ok 1, "Length $i" ;
            my $part = substr($compressed, 0, $i);
            writeFile($name, $part);
            my $gz = new $UncompressClass $name,
                                       -BlockSize   => $blocksize,
                                       -Transparent => $trans;
            if ($trans) {
                ok $gz;
                ok ! $gz->error() ;
                my $buff = '';
                ok $gz->read($buff) == length $part ;
                ok $buff eq $part ;
                ok $gz->eof() ;
                $gz->close();
            }
            else {
                ok !$gz;
            }
        }

        foreach my $i ($blocksize+1 .. length($compressed)-1)
        {
        
            my $lex = new LexFile my $name ;
        
            ok 1, "Length $i" ;
            my $part = substr($compressed, 0, $i);
            writeFile($name, $part);
            ok my $gz = new $UncompressClass $name,
                                             -BlockSize   => $blocksize,
                                             -Transparent => $trans;
            my $un ;
            my $status = 0 ;
            $status = $gz->read($un) while $status >= 0 ;
            ok $status < 0 ;
            ok $gz->eof() ;
            ok $gz->error() ;
            $gz->close();
        }
    }
    
}
Commit	Line	Data
16816334	1	BEGIN {
d695c1a1	2	if ($ENV{PERL_CORE}) {
16816334	3	chdir 't' if -d 't';
0ecadccd	4	@INC = ("../lib", "lib");
16816334	5	}
16816334	6	}
642e522c	7
	8	use lib 't';
	9	use strict;
	10	use warnings;
	11	use bytes;
	12
	13	use Test::More ;
	14	use ZlibTestUtils;
	15
	16	BEGIN {
	17	# use Test::NoWarnings, if available
	18	my $extra = 0 ;
	19	$extra = 1
	20	if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
	21
	22	plan tests => 2374 + $extra;
	23
	24	use_ok('Compress::Zlib', 2) ;
	25
	26	use_ok('IO::Compress::Gzip', qw($GzipError)) ;
	27	use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
	28
	29	use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
	30	use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
	31
	32	use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
	33	use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
	34
	35	}
	36
	37
	38	my $hello = <<EOM ;
	39	hello world
	40	this is a test
	41	some more stuff on this line
	42	ad finally...
	43	EOM
	44
	45	my $blocksize = 10 ;
	46
	47
	48	foreach my $CompressClass ('IO::Compress::Gzip', 'IO::Compress::Deflate')
	49	{
	50	my $UncompressClass = getInverse($CompressClass);
	51
	52
	53	my $compressed ;
	54	my $cc ;
	55	my $gz ;
	56	if ($CompressClass eq 'IO::Compress::Gzip') {
	57	ok( my $x = new IO::Compress::Gzip \$compressed,
	58	-Name => "My name",
	59	-Comment => "a comment",
	60	-ExtraField => ['ab' => "extra"],
	61	-HeaderCRC => 1);
	62	ok $x->write($hello) ;
	63	ok $x->close ;
	64	$cc = $compressed ;
	65
	66	ok($gz = new IO::Uncompress::Gunzip \$cc,
	67	-Transparent => 0)
	68	or diag "$GunzipError";
	69	my $un;
	70	ok $gz->read($un) > 0 ;
71	ok $gz->close();
72	ok $un eq $hello ;
73	}
74	else {
75	ok( my $x = new $CompressClass(\$compressed));
76	ok $x->write($hello) ;
77	ok $x->close ;
78	$cc = $compressed ;
79
80	ok($gz = new $UncompressClass(\$cc,
81	-Transparent => 0))
82	or diag "$GunzipError";
83	my $un;
84	ok $gz->read($un) > 0 ;
85	ok $gz->close();
86	ok $un eq $hello ;
87	}
88
89
90	for my $trans ( 0 .. 1)
91	{
92	title "Testing $CompressClass, Transparent $trans";
93
94	my $info = $gz->getHeaderInfo() ;
95	my $header_size = $info->{HeaderLength};
96	my $trailer_size = $info->{TrailerLength};
97	ok 1, "Compressed size is " . length($compressed) ;
98	ok 1, "Header size is $header_size" ;
99	ok 1, "Trailer size is $trailer_size" ;
100
101	title "Fingerprint Truncation";
102	foreach my $i (1)
103	{
9f2e3514	104	my $lex = new LexFile my $name ;
642e522c	105
	106	ok 1, "Length $i" ;
	107	my $part = substr($compressed, 0, $i);
	108	writeFile($name, $part);
	109
	110	my $gz = new $UncompressClass $name,
	111	-BlockSize => $blocksize,
	112	-Transparent => $trans;
	113	if ($trans) {
	114	ok $gz;
	115	ok ! $gz->error() ;
	116	my $buff ;
	117	ok $gz->read($buff) == length($part) ;
	118	ok $buff eq $part ;
	119	ok $gz->eof() ;
	120	$gz->close();
	121	}
	122	else {
	123	ok !$gz;
	124	}
	125
	126	}
	127
	128	title "Header Truncation";
	129	#
	130	# Any header corruption past the fingerprint is considered catastrophic
	131	# so even if Transparent is set, it should still fail
	132	#
	133	foreach my $i (2 .. $header_size -1)
	134	{
9f2e3514	135	my $lex = new LexFile my $name ;
642e522c	136
	137	ok 1, "Length $i" ;
	138	my $part = substr($compressed, 0, $i);
	139	writeFile($name, $part);
	140	ok ! defined new $UncompressClass $name,
	141	-BlockSize => $blocksize,
	142	-Transparent => $trans;
	143	#ok $gz->eof() ;
	144	}
	145
	146	title "Compressed Data Truncation";
	147	foreach my $i ($header_size .. length($compressed) - 1 - $trailer_size)
	148	{
	149
9f2e3514	150	my $lex = new LexFile my $name ;
642e522c	151
	152	ok 1, "Length $i" ;
	153	my $part = substr($compressed, 0, $i);
	154	writeFile($name, $part);
	155	ok my $gz = new $UncompressClass $name,
	156	-BlockSize => $blocksize,
	157	-Transparent => $trans;
	158	my $un ;
	159	my $status = 0 ;
	160	$status = $gz->read($un) while $status >= 0 ;
	161	ok $status < 0 ;
	162	ok $gz->eof() ;
	163	ok $gz->error() ;
	164	$gz->close();
	165	}
	166
	167	# RawDeflate does not have a trailer
	168	next if $CompressClass eq 'IO::Compress::RawDeflate' ;
	169
	170	title "Compressed Trailer Truncation";
	171	foreach my $i (length($compressed) - $trailer_size .. length($compressed) -1 )
	172	{
	173	foreach my $lax (0, 1)
	174	{
9f2e3514	175	my $lex = new LexFile my $name ;
642e522c	176
	177	ok 1, "Length $i, Lax $lax" ;
	178	my $part = substr($compressed, 0, $i);
	179	writeFile($name, $part);
	180	ok my $gz = new $UncompressClass $name,
	181	-BlockSize => $blocksize,
	182	-Strict => !$lax,
	183	-Append => 1,
	184	-Transparent => $trans;
	185	my $un = '';
	186	my $status = 1 ;
	187	$status = $gz->read($un) while $status > 0 ;
	188
	189	if ($lax)
	190	{
	191	is $un, $hello;
	192	is $status, 0
	193	or diag "Status $status Error is " . $gz->error() ;
	194	ok $gz->eof()
	195	or diag "Status $status Error is " . $gz->error() ;
	196	ok ! $gz->error() ;
	197	}
	198	else
	199	{
	200	ok $status < 0
	201	or diag "Status $status Error is " . $gz->error() ;
	202	ok $gz->eof()
	203	or diag "Status $status Error is " . $gz->error() ;
	204	ok $gz->error() ;
	205	}
	206
	207	$gz->close();
	208	}
	209	}
	210	}
	211	}
	212
	213
	214	foreach my $CompressClass ( 'IO::Compress::RawDeflate')
	215	{
	216	my $UncompressClass = getInverse($CompressClass);
	217	my $Error = getErrorRef($UncompressClass);
	218
	219	my $compressed ;
	220	ok( my $x = new IO::Compress::RawDeflate \$compressed);
	221	ok $x->write($hello) ;
	222	ok $x->close ;
	223
	224
	225	my $cc = $compressed ;
	226
	227	my $gz ;
	228	ok($gz = new $UncompressClass(\$cc,
	229	-Transparent => 0))
	230	or diag "$$Error\n";
	231	my $un;
	232	ok $gz->read($un) > 0 ;
	233	ok $gz->close();
	234	ok $un eq $hello ;
	235
	236	for my $trans (0 .. 1)
	237	{
	238	title "Testing $CompressClass, Transparent = $trans";
	239
240	my $info = $gz->getHeaderInfo() ;
241	my $header_size = $info->{HeaderLength};
242	my $trailer_size = $info->{TrailerLength};
243	ok 1, "Compressed size is " . length($compressed) ;
244	ok 1, "Header size is $header_size" ;
245	ok 1, "Trailer size is $trailer_size" ;
246
247
248	title "Compressed Data Truncation";
249	foreach my $i (0 .. $blocksize)
250	{
251
9f2e3514	252	my $lex = new LexFile my $name ;
642e522c	253
	254	ok 1, "Length $i" ;
	255	my $part = substr($compressed, 0, $i);
	256	writeFile($name, $part);
	257	my $gz = new $UncompressClass $name,
	258	-BlockSize => $blocksize,
	259	-Transparent => $trans;
	260	if ($trans) {
	261	ok $gz;
	262	ok ! $gz->error() ;
	263	my $buff = '';
	264	ok $gz->read($buff) == length $part ;
	265	ok $buff eq $part ;
	266	ok $gz->eof() ;
	267	$gz->close();
	268	}
	269	else {
	270	ok !$gz;
	271	}
	272	}
	273
	274	foreach my $i ($blocksize+1 .. length($compressed)-1)
	275	{
	276
9f2e3514	277	my $lex = new LexFile my $name ;
642e522c	278
	279	ok 1, "Length $i" ;
	280	my $part = substr($compressed, 0, $i);
	281	writeFile($name, $part);
	282	ok my $gz = new $UncompressClass $name,
	283	-BlockSize => $blocksize,
	284	-Transparent => $trans;
	285	my $un ;
	286	my $status = 0 ;
	287	$status = $gz->read($un) while $status >= 0 ;
	288	ok $status < 0 ;
	289	ok $gz->eof() ;
	290	ok $gz->error() ;
	291	$gz->close();
	292	}
	293	}
	294
	295	}
	296