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


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