[p5sagit/p5-mst-13.2.git] / ext / Compress / Zlib / t / 21newtied.t

BEGIN {
    if ($ENV{PERL_CORE}) {
	chdir 't' if -d 't';
	@INC = '../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 $name = "test.gz" ;
        my $lex = new LexFile $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 $name = "test.gz" ;
        my $lex = new LexFile $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 $name = "test.gz" ;
        my $lex = new LexFile $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 $name = "test.gz" ;
        my $lex = new LexFile $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';
	4	@INC = '../lib';
	5	}
	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
102	my $name = "test.gz" ;
103	my $lex = new LexFile $name ;
104
105	my $io = $CompressClass->new($name);
106
107	is tell($io), 0 ;
108	is $io->tell(), 0 ;
109
110	my $heisan = "Heisan\n";
111	print $io $heisan ;
112
113	ok ! eof($io);
114	ok ! $io->eof();
115
116	is tell($io), length($heisan) ;
117	is $io->tell(), length($heisan) ;
118
119	$io->print("a", "b", "c");
120
121	{
122	local($\) = "\n";
123	print $io "d", "e";
124	local($,) = ",";
125	print $io "f", "g", "h";
126	}
127
128	my $foo = "1234567890";
129
130	ok syswrite($io, $foo, length($foo)) == length($foo) ;
131	if ( $[ < 5.6 )
132	{ is $io->syswrite($foo, length $foo), length $foo }
133	else
134	{ is $io->syswrite($foo), length $foo }
135	ok $io->syswrite($foo, length($foo)) == length $foo;
136	ok $io->write($foo, length($foo), 5) == 5;
137	ok $io->write("xxx\n", 100, -1) == 1;
138
139	for (1..3) {
140	printf $io "i(%d)", $_;
141	$io->printf("[%d]\n", $_);
142	}
143	select $io;
144	print "\n";
145	select STDOUT;
146
147	close $io ;
148
149	ok eof($io);
150	ok $io->eof();
151
152	is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
153	("1234567890" x 3) . "67890\n" .
154	"i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
155
156
157	}
158
159	{
160	# Read
161	my $str = <<EOT;
162	This is an example
163	of a paragraph
164
165
166	and a single line.
167
168	EOT
169
170	my $name = "test.gz" ;
171	my $lex = new LexFile $name ;
172
173	my $iow = new $CompressClass $name ;
174	print $iow $str ;
175	close $iow;
176
177	my @tmp;
178	my $buf;
179	{
180	my $io = new $UncompressClass $name ;
181
182	ok ! $io->eof;
183	ok ! eof $io;
184	is $io->tell(), 0 ;
185	is tell($io), 0 ;
186	my @lines = <$io>;
187	is @lines, 6
188	or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
189	is $lines[1], "of a paragraph\n" ;
190	is join('', @lines), $str ;
191	is $., 6;
192	#print "TELL says " . tell($io) , " should be ${ \length($str) }\n" ;
193	is $io->tell(), length($str) ;
194	is tell($io), length($str) ;
195
196	ok $io->eof;
197	ok eof $io;
198
199	ok ! ( defined($io->getline) \|\|
200	(@tmp = $io->getlines) \|\|
201	defined(<$io>) \|\|
202	defined($io->getc) \|\|
203	read($io, $buf, 100) != 0) ;
204	}
205
206
207	{
208	local $/; # slurp mode
209	my $io = $UncompressClass->new($name);
210	ok ! $io->eof;
211	my @lines = $io->getlines;
212	ok $io->eof;
213	ok @lines == 1 && $lines[0] eq $str;
214
215	$io = $UncompressClass->new($name);
216	ok ! $io->eof;
217	my $line = <$io>;
218	ok $line eq $str;
219	ok $io->eof;
220	}
221
222	{
223	local $/ = ""; # paragraph mode
224	my $io = $UncompressClass->new($name);
225	ok ! $io->eof;
226	my @lines = <$io>;
227	ok $io->eof;
228	ok @lines == 2
229	or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
230	ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
231	or print "# $lines[0]\n";
232	ok $lines[1] eq "and a single line.\n\n";
233	}
234
235	{
236	local $/ = "is";
237	my $io = $UncompressClass->new($name);
238	my @lines = ();
239	my $no = 0;
240	my $err = 0;
241	ok ! $io->eof;
242	while (<$io>) {
243	push(@lines, $_);
244	$err++ if $. != ++$no;
245	}
246
247	ok $err == 0 ;
248	ok $io->eof;
249
250	ok @lines == 3
251	or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
252	ok join("-", @lines) eq
253	"This- is- an example\n" .
254	"of a paragraph\n\n\n" .
255	"and a single line.\n\n";
256	}
257
258
259	# Test read
260
261	{
262	my $io = $UncompressClass->new($name);
263
264	ok $io, "opened ok" ;
265
266	#eval { read($io, $buf, -1); } ;
267	#like $@, mkErr("length parameter is negative"), "xxx $io $UncompressClass $RawInflateError" ;
268
269	#eval { read($io, 1) } ;
270	#like $@, mkErr("buffer parameter is read-only");
271
272	is read($io, $buf, 0), 0, "Requested 0 bytes" ;
273
274	ok read($io, $buf, 3) == 3 ;
275	ok $buf eq "Thi";
276
277	ok sysread($io, $buf, 3, 2) == 3 ;
278	ok $buf eq "Ths i"
279	or print "# [$buf]\n" ;;
280	ok ! $io->eof;
281
282	# $io->seek(-4, 2);
283	#
284	# ok ! $io->eof;
285	#
286	# ok read($io, $buf, 20) == 4 ;
287	# ok $buf eq "e.\n\n";
288	#
289	# ok read($io, $buf, 20) == 0 ;
290	# ok $buf eq "";
291	#
292	# ok ! $io->eof;
293	}
294
295	}
296
297
298
299	{
300	title "seek tests" ;
301
302	my $name = "test.gz" ;
303	my $lex = new LexFile $name ;
304
305	my $first = "beginning" ;
306	my $last = "the end" ;
307	my $iow = new $CompressClass $name ;
308	print $iow $first ;
309	ok seek $iow, 10, SEEK_CUR ;
310	is tell($iow), length($first)+10;
311	ok $iow->seek(0, SEEK_CUR) ;
312	is tell($iow), length($first)+10;
313	print $iow $last ;
314	close $iow;
315
316	my $io = $UncompressClass->new($name);
317	ok myGZreadFile($name) eq $first . "\x00" x 10 . $last ;
318
319	$io = $UncompressClass->new($name);
320	ok seek $io, length($first)+10, SEEK_CUR ;
321	ok ! $io->eof;
322	is tell($io), length($first)+10;
323	ok seek $io, 0, SEEK_CUR ;
324	is tell($io), length($first)+10;
325	my $buff ;
326	ok read $io, $buff, 100 ;
327	ok $buff eq $last ;
328	ok $io->eof;
329	}
330
331	if (! $BadPerl)
332	{
333	# seek error cases
334	my $b ;
335	my $a = new $CompressClass(\$b) ;
336
337	ok ! $a->error() ;
338	eval { seek($a, -1, 10) ; };
339	like $@, mkErr("^seek: unknown value, 10, for whence parameter");
340
341	eval { seek($a, -1, SEEK_END) ; };
342	like $@, mkErr("^cannot seek backwards");
343
344	print $a "fred";
345	close $a ;
346
347
348	my $u = new $UncompressClass(\$b) ;
349
350	eval { seek($u, -1, 10) ; };
351	like $@, mkErr("^seek: unknown value, 10, for whence parameter");
352
353	eval { seek($u, -1, SEEK_END) ; };
354	like $@, mkErr("^seek: SEEK_END not allowed");
355
356	eval { seek($u, -1, SEEK_CUR) ; };
357	like $@, mkErr("^cannot seek backwards");
358	}
359
360	{
361	title 'fileno' ;
362
363	my $name = "test.gz" ;
364	my $lex = new LexFile $name ;
365
366	my $hello = <<EOM ;
367	hello world
368	this is a test
369	EOM
370
371	{
372	my $fh ;
373	ok $fh = new IO::File ">$name" ;
374	my $x ;
375	ok $x = new $CompressClass $fh ;
376
377	ok $x->fileno() == fileno($fh) ;
378	ok $x->fileno() == fileno($x) ;
379	ok $x->write($hello) ;
380	ok $x->close ;
381	$fh->close() ;
382	}
383
384	my $uncomp;
385	{
386	my $x ;
387	ok my $fh1 = new IO::File "<$name" ;
388	ok $x = new $UncompressClass $fh1, -Append => 1 ;
389	ok $x->fileno() == fileno $fh1 ;
390	ok $x->fileno() == fileno $x ;
391
392	1 while $x->read($uncomp) > 0 ;
393
394	ok $x->close ;
395	}
396
397	ok $hello eq $uncomp ;
398	}
399	}
400