[p5sagit/p5-mst-13.2.git] / ext / Compress / Zlib / t / 21newtied.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;

our ($BadPerl);
 
BEGIN 
{ 
    plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" )
        if $] < 5.006 ;
     
    my $tests ;

    $BadPerl = ($] >= 5.006 or $] <= 5.008) ;

    if ($BadPerl) {
        $tests = 242 ;
    }
    else {
        $tests = 242 ;
    }

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

    plan tests => $tests + $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)) ;
 

}


use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);


our ($UncompressClass);


sub myGZreadFile
{
    my $filename = shift ;
    my $init = shift ;


    my $fil = new $UncompressClass $filename,
                                    -Strict   => 1,
                                    -Append   => 1
                                    ;

    my $data ;
    $data = $init if defined $init ;
    1 while $fil->read($data) > 0;

    $fil->close ;
    return $data ;
}

# Check zlib_version and ZLIB_VERSION are the same.
is Compress::Zlib::zlib_version, ZLIB_VERSION, 
    "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;


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

    title "Testing $CompressClass and $UncompressClass";


    {
        # Write
        # these tests come almost 100% from IO::String

        my $lex = new LexFile my $name ;

        my $io = $CompressClass->new($name);

        is tell($io), 0 ;
        is $io->tell(), 0 ;

        my $heisan = "Heisan\n";
        print $io $heisan ;

        ok ! eof($io);
        ok ! $io->eof();

        is tell($io), length($heisan) ;
        is $io->tell(), length($heisan) ;

        $io->print("a", "b", "c");

        {
            local($\) = "\n";
            print $io "d", "e";
            local($,) = ",";
            print $io "f", "g", "h";
        }

        my $foo = "1234567890";
        
        ok syswrite($io, $foo, length($foo)) == length($foo) ;
        if ( $[ < 5.6 )
          { is $io->syswrite($foo, length $foo), length $foo }
        else
          { is $io->syswrite($foo), length $foo }
        ok $io->syswrite($foo, length($foo)) == length $foo;
        ok $io->write($foo, length($foo), 5) == 5;
        ok $io->write("xxx\n", 100, -1) == 1;

        for (1..3) {
            printf $io "i(%d)", $_;
            $io->printf("[%d]\n", $_);
        }
        select $io;
        print "\n";
        select STDOUT;

        close $io ;

        ok eof($io);
        ok $io->eof();

        is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
                                ("1234567890" x 3) . "67890\n" .
                                    "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";


    }

    {
        # Read
        my $str = <<EOT;
This is an example
of a paragraph


and a single line.

EOT

        my $lex = new LexFile my $name ;

        my $iow = new $CompressClass $name ;
        print $iow $str ;
        close $iow;

        my @tmp;
        my $buf;
        {
            my $io = new $UncompressClass $name ;
        
            ok ! $io->eof;
            ok ! eof $io;
            is $io->tell(), 0 ;
            is tell($io), 0 ;
            my @lines = <$io>;
            is @lines, 6
                or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
            is $lines[1], "of a paragraph\n" ;
            is join('', @lines), $str ;
            is $., 6; 
    #print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ;
            is $io->tell(), length($str) ;
            is tell($io), length($str) ;
        
            ok $io->eof;
            ok eof $io;

            ok ! ( defined($io->getline)  ||
                      (@tmp = $io->getlines) ||
                      defined(<$io>)         ||
                      defined($io->getc)     ||
                      read($io, $buf, 100)   != 0) ;
        }
        
        
        {
            local $/;  # slurp mode
            my $io = $UncompressClass->new($name);
            ok ! $io->eof;
            my @lines = $io->getlines;
            ok $io->eof;
            ok @lines == 1 && $lines[0] eq $str;
        
            $io = $UncompressClass->new($name);
            ok ! $io->eof;
            my $line = <$io>;
            ok $line eq $str;
            ok $io->eof;
        }
        
        {
            local $/ = "";  # paragraph mode
            my $io = $UncompressClass->new($name);
            ok ! $io->eof;
            my @lines = <$io>;
            ok $io->eof;
            ok @lines == 2 
                or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
            ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
                or print "# $lines[0]\n";
            ok $lines[1] eq "and a single line.\n\n";
        }
        
        {
            local $/ = "is";
            my $io = $UncompressClass->new($name);
            my @lines = ();
            my $no = 0;
            my $err = 0;
            ok ! $io->eof;
            while (<$io>) {
                push(@lines, $_);
                $err++ if $. != ++$no;
            }
        
            ok $err == 0 ;
            ok $io->eof;
        
            ok @lines == 3 
                or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
            ok join("-", @lines) eq
                             "This- is- an example\n" .
                            "of a paragraph\n\n\n" .
                            "and a single line.\n\n";
        }
        
        
        # Test read
        
        {
            my $io = $UncompressClass->new($name);

            ok $io, "opened ok" ;
        
            #eval { read($io, $buf, -1); } ;
            #like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ;

            #eval { read($io, 1) } ;
            #like $@, mkErr("buffer parameter is read-only");

            is read($io, $buf, 0), 0, "Requested 0 bytes" ;

            ok read($io, $buf, 3) == 3 ;
            ok $buf eq "Thi";
        
            ok sysread($io, $buf, 3, 2) == 3 ;
            ok $buf eq "Ths i"
                or print "# [$buf]\n" ;;
            ok ! $io->eof;
        
    #        $io->seek(-4, 2);
    #    
    #        ok ! $io->eof;
    #    
    #        ok read($io, $buf, 20) == 4 ;
    #        ok $buf eq "e.\n\n";
    #    
    #        ok read($io, $buf, 20) == 0 ;
    #        ok $buf eq "";
    #   
    #        ok ! $io->eof;
        }

    }


    {
        title "seek tests" ;

        my $lex = new LexFile my $name ;

        my $first = "beginning" ;
        my $last  = "the end" ;
        my $iow = new $CompressClass $name ;
        print $iow $first ;
        ok seek $iow, 10, SEEK_CUR ;
        is tell($iow), length($first)+10;
        ok $iow->seek(0, SEEK_CUR) ;
        is tell($iow), length($first)+10;
        print $iow $last ;
        close $iow;

        my $io = $UncompressClass->new($name);
        ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ;

        $io = $UncompressClass->new($name);
        ok seek $io, length($first)+10, SEEK_CUR ;
        ok ! $io->eof;
        is tell($io), length($first)+10;
        ok seek $io, 0, SEEK_CUR ;
        is tell($io), length($first)+10;
        my $buff ;
        ok read $io, $buff, 100 ;
        ok $buff eq $last ;
        ok $io->eof;
    }

    if (! $BadPerl)
    {
        # seek error cases
        my $b ;
        my $a = new $CompressClass(\$b)  ;

        ok ! $a->error() ;
        eval { seek($a, -1, 10) ; };
        like $@, mkErr("^seek: unknown value, 10, for whence parameter");

        eval { seek($a, -1, SEEK_END) ; };
        like $@, mkErr("^cannot seek backwards");

        print $a "fred";
        close $a ;


        my $u = new $UncompressClass(\$b)  ;

        eval { seek($u, -1, 10) ; };
        like $@, mkErr("^seek: unknown value, 10, for whence parameter");

        eval { seek($u, -1, SEEK_END) ; };
        like $@, mkErr("^seek: SEEK_END not allowed");

        eval { seek($u, -1, SEEK_CUR) ; };
        like $@, mkErr("^cannot seek backwards");
    }

    {
        title 'fileno' ;

        my $lex = new LexFile my $name ;

        my $hello = <<EOM ;
hello world
this is a test
EOM

        {
          my $fh ;
          ok $fh = new IO::File ">$name" ;
          my $x ;
          ok $x = new $CompressClass $fh  ;

          ok $x->fileno() == fileno($fh) ;
          ok $x->fileno() == fileno($x) ;
          ok $x->write($hello) ;
          ok $x->close ;
          $fh->close() ;
        }

        my $uncomp;
        {
          my $x ;
          ok my $fh1 = new IO::File "<$name" ;
          ok $x = new $UncompressClass $fh1, -Append => 1  ;
          ok $x->fileno() == fileno $fh1 ;
          ok $x->fileno() == fileno $x ;

          1 while $x->read($uncomp) > 0 ;

          ok $x->close ;
        }

        ok $hello eq $uncomp ;
    }
}
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	our ($BadPerl);
	17
	18	BEGIN
	19	{
	20	plan(skip_all => "Extra Tied Filehandle needs Perl 5.6 or better - you have Perl $]" )
	21	if $] < 5.006 ;
	22
	23	my $tests ;
	24
	25	$BadPerl = ($] >= 5.006 or $] <= 5.008) ;
	26
	27	if ($BadPerl) {
	28	$tests = 242 ;
	29	}
	30	else {
	31	$tests = 242 ;
	32	}
	33
	34	# use Test::NoWarnings, if available
	35	my $extra = 0 ;
	36	$extra = 1
	37	if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 };
	38
	39	plan tests => $tests + $extra ;
	40
	41	use_ok('Compress::Zlib', 2) ;
	42
	43	use_ok('IO::Compress::Gzip', qw($GzipError)) ;
	44	use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
	45
	46	use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
	47	use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
	48
	49	use_ok('IO::Compress::RawDeflate', qw($RawDeflateError)) ;
	50	use_ok('IO::Uncompress::RawInflate', qw($RawInflateError)) ;
	51
	52
	53	}
	54
	55
	56	use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
	57
	58
	59	our ($UncompressClass);
	60
	61
	62	sub myGZreadFile
	63	{
	64	my $filename = shift ;
	65	my $init = shift ;
	66
	67
	68	my $fil = new $UncompressClass $filename,
	69	-Strict => 1,
	70	-Append => 1
71	;
72
73	my $data ;
74	$data = $init if defined $init ;
75	1 while $fil->read($data) > 0;
76
77	$fil->close ;
78	return $data ;
79	}
80
81	# Check zlib_version and ZLIB_VERSION are the same.
82	is Compress::Zlib::zlib_version, ZLIB_VERSION,
83	"ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
84
85
86
87	foreach my $CompressClass ('IO::Compress::Gzip',
88	'IO::Compress::Deflate',
89	'IO::Compress::RawDeflate',
90	)
91	{
92	$UncompressClass = getInverse($CompressClass);
93
94	title "Testing $CompressClass and $UncompressClass";
95
96
97
98	{
99	# Write
100	# these tests come almost 100% from IO::String
101
9f2e3514	102	my $lex = new LexFile my $name ;
642e522c	103
	104	my $io = $CompressClass->new($name);
	105
	106	is tell($io), 0 ;
	107	is $io->tell(), 0 ;
	108
	109	my $heisan = "Heisan\n";
	110	print $io $heisan ;
	111
	112	ok ! eof($io);
	113	ok ! $io->eof();
	114
	115	is tell($io), length($heisan) ;
	116	is $io->tell(), length($heisan) ;
	117
	118	$io->print("a", "b", "c");
	119
	120	{
	121	local($\) = "\n";
	122	print $io "d", "e";
	123	local($,) = ",";
	124	print $io "f", "g", "h";
	125	}
	126
	127	my $foo = "1234567890";
	128
	129	ok syswrite($io, $foo, length($foo)) == length($foo) ;
	130	if ( $[ < 5.6 )
	131	{ is $io->syswrite($foo, length $foo), length $foo }
	132	else
	133	{ is $io->syswrite($foo), length $foo }
	134	ok $io->syswrite($foo, length($foo)) == length $foo;
	135	ok $io->write($foo, length($foo), 5) == 5;
	136	ok $io->write("xxx\n", 100, -1) == 1;
	137
	138	for (1..3) {
	139	printf $io "i(%d)", $_;
	140	$io->printf("[%d]\n", $_);
	141	}
	142	select $io;
	143	print "\n";
	144	select STDOUT;
	145
	146	close $io ;
	147
	148	ok eof($io);
	149	ok $io->eof();
	150
	151	is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
	152	("1234567890" x 3) . "67890\n" .
	153	"i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
	154
	155
	156	}
	157
	158	{
	159	# Read
	160	my $str = <<EOT;
	161	This is an example
	162	of a paragraph
	163
	164
	165	and a single line.
	166
167	EOT
168
9f2e3514	169	my $lex = new LexFile my $name ;
642e522c	170
	171	my $iow = new $CompressClass $name ;
	172	print $iow $str ;
	173	close $iow;
	174
	175	my @tmp;
	176	my $buf;
	177	{
	178	my $io = new $UncompressClass $name ;
	179
	180	ok ! $io->eof;
	181	ok ! eof $io;
	182	is $io->tell(), 0 ;
	183	is tell($io), 0 ;
	184	my @lines = <$io>;
	185	is @lines, 6
	186	or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
	187	is $lines[1], "of a paragraph\n" ;
	188	is join('', @lines), $str ;
	189	is $., 6;
	190	#print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ;
	191	is $io->tell(), length($str) ;
	192	is tell($io), length($str) ;
	193
	194	ok $io->eof;
	195	ok eof $io;
	196
	197	ok ! ( defined($io->getline) \|\|
	198	(@tmp = $io->getlines) \|\|
	199	defined(<$io>) \|\|
	200	defined($io->getc) \|\|
	201	read($io, $buf, 100) != 0) ;
	202	}
	203
	204
	205	{
	206	local $/; # slurp mode
	207	my $io = $UncompressClass->new($name);
	208	ok ! $io->eof;
	209	my @lines = $io->getlines;
	210	ok $io->eof;
	211	ok @lines == 1 && $lines[0] eq $str;
	212
	213	$io = $UncompressClass->new($name);
	214	ok ! $io->eof;
	215	my $line = <$io>;
	216	ok $line eq $str;
	217	ok $io->eof;
	218	}
	219
	220	{
	221	local $/ = ""; # paragraph mode
	222	my $io = $UncompressClass->new($name);
	223	ok ! $io->eof;
	224	my @lines = <$io>;
	225	ok $io->eof;
	226	ok @lines == 2
	227	or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
	228	ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
	229	or print "# $lines[0]\n";
	230	ok $lines[1] eq "and a single line.\n\n";
	231	}
	232
	233	{
234	local $/ = "is";
235	my $io = $UncompressClass->new($name);
236	my @lines = ();
237	my $no = 0;
238	my $err = 0;
239	ok ! $io->eof;
240	while (<$io>) {
241	push(@lines, $_);
242	$err++ if $. != ++$no;
243	}
244
245	ok $err == 0 ;
246	ok $io->eof;
247
248	ok @lines == 3
249	or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
250	ok join("-", @lines) eq
251	"This- is- an example\n" .
252	"of a paragraph\n\n\n" .
253	"and a single line.\n\n";
254	}
255
256
257	# Test read
258
259	{
260	my $io = $UncompressClass->new($name);
261
262	ok $io, "opened ok" ;
263
264	#eval { read($io, $buf, -1); } ;
265	#like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ;
266
267	#eval { read($io, 1) } ;
268	#like $@, mkErr("buffer parameter is read-only");
269
270	is read($io, $buf, 0), 0, "Requested 0 bytes" ;
271
272	ok read($io, $buf, 3) == 3 ;
273	ok $buf eq "Thi";
274
275	ok sysread($io, $buf, 3, 2) == 3 ;
276	ok $buf eq "Ths i"
277	or print "# [$buf]\n" ;;
278	ok ! $io->eof;
279
280	# $io->seek(-4, 2);
281	#
282	# ok ! $io->eof;
283	#
284	# ok read($io, $buf, 20) == 4 ;
285	# ok $buf eq "e.\n\n";
286	#
287	# ok read($io, $buf, 20) == 0 ;
288	# ok $buf eq "";
289	#
290	# ok ! $io->eof;
291	}
292
293	}
294
295
296
297	{
298	title "seek tests" ;
299
9f2e3514	300	my $lex = new LexFile my $name ;
642e522c	301
	302	my $first = "beginning" ;
	303	my $last = "the end" ;
	304	my $iow = new $CompressClass $name ;
	305	print $iow $first ;
	306	ok seek $iow, 10, SEEK_CUR ;
	307	is tell($iow), length($first)+10;
	308	ok $iow->seek(0, SEEK_CUR) ;
	309	is tell($iow), length($first)+10;
	310	print $iow $last ;
	311	close $iow;
	312
	313	my $io = $UncompressClass->new($name);
	314	ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ;
	315
	316	$io = $UncompressClass->new($name);
	317	ok seek $io, length($first)+10, SEEK_CUR ;
	318	ok ! $io->eof;
	319	is tell($io), length($first)+10;
	320	ok seek $io, 0, SEEK_CUR ;
	321	is tell($io), length($first)+10;
	322	my $buff ;
	323	ok read $io, $buff, 100 ;
	324	ok $buff eq $last ;
	325	ok $io->eof;
	326	}
	327
	328	if (! $BadPerl)
	329	{
	330	# seek error cases
	331	my $b ;
	332	my $a = new $CompressClass(\$b) ;
	333
	334	ok ! $a->error() ;
	335	eval { seek($a, -1, 10) ; };
	336	like $@, mkErr("^seek: unknown value, 10, for whence parameter");
	337
	338	eval { seek($a, -1, SEEK_END) ; };
	339	like $@, mkErr("^cannot seek backwards");
	340
	341	print $a "fred";
	342	close $a ;
	343
	344
	345	my $u = new $UncompressClass(\$b) ;
	346
	347	eval { seek($u, -1, 10) ; };
	348	like $@, mkErr("^seek: unknown value, 10, for whence parameter");
	349
	350	eval { seek($u, -1, SEEK_END) ; };
	351	like $@, mkErr("^seek: SEEK_END not allowed");
	352
	353	eval { seek($u, -1, SEEK_CUR) ; };
	354	like $@, mkErr("^cannot seek backwards");
	355	}
	356
	357	{
	358	title 'fileno' ;
	359
9f2e3514	360	my $lex = new LexFile my $name ;
642e522c	361
	362	my $hello = <<EOM ;
	363	hello world
	364	this is a test
	365	EOM
	366
	367	{
	368	my $fh ;
	369	ok $fh = new IO::File ">$name" ;
	370	my $x ;
	371	ok $x = new $CompressClass $fh ;
	372
	373	ok $x->fileno() == fileno($fh) ;
	374	ok $x->fileno() == fileno($x) ;
	375	ok $x->write($hello) ;
	376	ok $x->close ;
	377	$fh->close() ;
	378	}
	379
	380	my $uncomp;
	381	{
	382	my $x ;
	383	ok my $fh1 = new IO::File "<$name" ;
	384	ok $x = new $UncompressClass $fh1, -Append => 1 ;
	385	ok $x->fileno() == fileno $fh1 ;
	386	ok $x->fileno() == fileno $x ;
	387
	388	1 while $x->read($uncomp) > 0 ;
	389
	390	ok $x->close ;
	391	}
	392
	393	ok $hello eq $uncomp ;
	394	}
	395	}
	396