[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/compress");
    }
}

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

# TODO -- split out & add zip/bzip2

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