[perl5.git] / t / lib / compress / tied.pl


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

use Test::More ;
use CompTestUtils;

our ($BadPerl, $UncompressClass);
 
BEGIN 
{ 
    plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" )
        if $] < 5.005 ;

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

    my $tests ;
    $BadPerl = ($] >= 5.006 and $] <= 5.008) ;

    if ($BadPerl) {
        $tests = 241 ;
    }
    else {
        $tests = 249 ;
    }

    plan tests => $tests + $extra ;

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

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 ;
}

sub run
{

    my $CompressClass   = identify();
    $UncompressClass = getInverse($CompressClass);
    my $Error           = getErrorRef($CompressClass);
    my $UnError         = getErrorRef($UncompressClass);

    {
        next if $BadPerl ;


        title "Testing $CompressClass";

            
        my $x ;
        my $gz = new $CompressClass(\$x); 

        my $buff ;

        eval { getc($gz) } ;
        like $@, mkErr("^getc Not Available: File opened only for output");

        eval { read($gz, $buff, 1) } ;
        like $@, mkErr("^read Not Available: File opened only for output");

        eval { <$gz>  } ;
        like $@, mkErr("^readline Not Available: File opened only for output");

    }

    {
        next if $BadPerl;
        $UncompressClass = getInverse($CompressClass);

        title "Testing $UncompressClass";

        my $gc ;
        my $guz = new $CompressClass(\$gc); 
        $guz->write("abc") ;
        $guz->close();

        my $x ;
        my $gz = new $UncompressClass(\$gc); 

        my $buff ;

        eval { print $gz "abc" } ;
        like $@, mkErr("^print Not Available: File opened only for intput");

        eval { printf $gz "fmt", "abc" } ;
        like $@, mkErr("^printf Not Available: File opened only for intput");

        #eval { write($gz, $buff, 1) } ;
        #like $@, mkErr("^write Not Available: File opened only for intput");

    }

    {
        $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 $io->tell(), 0 ;

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

            ok ! $io->eof;

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

            print($io "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 $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, "  Not EOF";
                is $io->tell(), 0, "  Tell is 0" ;
                my @lines = <$io>;
                is @lines, 6, "  Line is 6"
                    or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
                is $lines[1], "of a paragraph\n" ;
                is join('', @lines), $str ;
                is $., 6; 
                is $io->tell(), length($str) ;
            
                ok $io->eof;

                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);
            

                if (! $BadPerl) {
                    eval { read($io, $buf, -1) } ;
                    like $@, mkErr("length parameter is negative");
                }

                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;
            }

        }

        {
            # Read from non-compressed file

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


and a single line.

EOT

            my $lex = new LexFile my $name ;

            writeFile($name, $str);
            my @tmp;
            my $buf;
            {
                my $io = new $UncompressClass $name, -Transparent => 1 ;
            
                ok defined $io;
                ok ! $io->eof;
                ok $io->tell() == 0 ;
                my @lines = <$io>;
                ok @lines == 6; 
                ok $lines[1] eq "of a paragraph\n" ;
                ok join('', @lines) eq $str ;
                ok $. == 6; 
                ok $io->tell() == length($str) ;
            
                ok $io->eof;

                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 "# exected 2 lines, got " . scalar(@lines) . "\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 ;
                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 read($io, $buf, 3) == 3 ;
                ok $buf eq "Thi";
            
                ok sysread($io, $buf, 3, 2) == 3 ;
                ok $buf eq "Ths i";
                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;
            }


        }

        {
            # Vary the length parameter in a read

            my $str = <<EOT;
x
x
This is an example
of a paragraph


and a single line.

EOT
            $str = $str x 100 ;


            foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
            {
                foreach my $trans (0, 1)
                {
                    foreach my $append (0, 1)
                    {
                        title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;

                        my $lex = new LexFile my $name ;

                        if ($trans) {
                            writeFile($name, $str) ;
                        }
                        else {
                            my $iow = new $CompressClass $name ;
                            print $iow $str ;
                            close $iow;
                        }

                        
                        my $io = $UncompressClass->new($name, 
                                                       -Append => $append,
                                                       -Transparent  => $trans);
                    
                        my $buf;
                        
                        is $io->tell(), 0;

                        if ($append) {
                            1 while $io->read($buf, $bufsize) > 0;
                        }
                        else {
                            my $tmp ;
                            $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
                        }
                        is length $buf, length $str;
                        ok $buf eq $str ;
                        ok ! $io->error() ;
                        ok $io->eof;
                    }
                }
            }
        }

    }
}

1;
Commit	Line	Data
1a6a8453 PM	1
	2	use lib 't';
	3	use strict;
	4	use warnings;
	5	use bytes;
	6
	7	use Test::More ;
25f0751f	8	use CompTestUtils;
1a6a8453 PM	9
	10	our ($BadPerl, $UncompressClass);
	11
	12	BEGIN
	13	{
	14	plan(skip_all => "Tied Filehandle needs Perl 5.005 or better" )
	15	if $] < 5.005 ;
	16
	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	my $tests ;
	23	$BadPerl = ($] >= 5.006 and $] <= 5.008) ;
	24
	25	if ($BadPerl) {
cb7abd7f	26	$tests = 241 ;
1a6a8453 PM	27	}
1a6a8453 PM	28	else {
cb7abd7f	29	$tests = 249 ;
1a6a8453 PM	30	}
	31
	32	plan tests => $tests + $extra ;
	33
1a6a8453 PM	34	}
	35
	36
	37	use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
	38
	39
	40
	41	sub myGZreadFile
	42	{
	43	my $filename = shift ;
	44	my $init = shift ;
	45
	46
	47	my $fil = new $UncompressClass $filename,
	48	-Strict => 1,
	49	-Append => 1
	50	;
	51
	52	my $data ;
	53	$data = $init if defined $init ;
	54	1 while $fil->read($data) > 0;
	55
	56	$fil->close ;
	57	return $data ;
	58	}
	59
	60	sub run
	61	{
	62
	63	my $CompressClass = identify();
	64	$UncompressClass = getInverse($CompressClass);
	65	my $Error = getErrorRef($CompressClass);
	66	my $UnError = getErrorRef($UncompressClass);
	67
	68	{
	69	next if $BadPerl ;
	70
	71
	72	title "Testing $CompressClass";
	73
	74
	75	my $x ;
	76	my $gz = new $CompressClass(\$x);
	77
	78	my $buff ;
	79
	80	eval { getc($gz) } ;
	81	like $@, mkErr("^getc Not Available: File opened only for output");
	82
	83	eval { read($gz, $buff, 1) } ;
	84	like $@, mkErr("^read Not Available: File opened only for output");
	85
	86	eval { <$gz> } ;
	87	like $@, mkErr("^readline Not Available: File opened only for output");
	88
	89	}
	90
	91	{
	92	next if $BadPerl;
	93	$UncompressClass = getInverse($CompressClass);
	94
	95	title "Testing $UncompressClass";
	96
	97	my $gc ;
98	my $guz = new $CompressClass(\$gc);
99	$guz->write("abc") ;
100	$guz->close();
101
102	my $x ;
103	my $gz = new $UncompressClass(\$gc);
104
105	my $buff ;
106
107	eval { print $gz "abc" } ;
108	like $@, mkErr("^print Not Available: File opened only for intput");
109
110	eval { printf $gz "fmt", "abc" } ;
111	like $@, mkErr("^printf Not Available: File opened only for intput");
112
113	#eval { write($gz, $buff, 1) } ;
114	#like $@, mkErr("^write Not Available: File opened only for intput");
115
116	}
117
118	{
119	$UncompressClass = getInverse($CompressClass);
120
121	title "Testing $CompressClass and $UncompressClass";
122
123
124	{
125	# Write
126	# these tests come almost 100% from IO::String
127
128	my $lex = new LexFile my $name ;
129
130	my $io = $CompressClass->new($name);
131
132	is $io->tell(), 0 ;
133
134	my $heisan = "Heisan\n";
135	print $io $heisan ;
136
137	ok ! $io->eof;
138
139	is $io->tell(), length($heisan) ;
140
141	print($io "a", "b", "c");
142
143	{
144	local($\) = "\n";
145	print $io "d", "e";
146	local($,) = ",";
147	print $io "f", "g", "h";
148	}
149
150	my $foo = "1234567890";
151
152	ok syswrite($io, $foo, length($foo)) == length($foo) ;
153	if ( $[ < 5.6 )
154	{ is $io->syswrite($foo, length $foo), length $foo }
155	else
156	{ is $io->syswrite($foo), length $foo }
157	ok $io->syswrite($foo, length($foo)) == length $foo;
158	ok $io->write($foo, length($foo), 5) == 5;
159	ok $io->write("xxx\n", 100, -1) == 1;
160
161	for (1..3) {
162	printf $io "i(%d)", $_;
163	$io->printf("[%d]\n", $_);
164	}
165	select $io;
166	print "\n";
167	select STDOUT;
168
169	close $io ;
170
171	ok $io->eof;
172
173	is myGZreadFile($name), "Heisan\nabcde\nf,g,h\n" .
174	("1234567890" x 3) . "67890\n" .
175	"i(1)[1]\ni(2)[2]\ni(3)[3]\n\n";
176
177
178	}
179
180	{
181	# Read
182	my $str = <<EOT;
183	This is an example
184	of a paragraph
185
186
187	and a single line.
188
189	EOT
190
191	my $lex = new LexFile my $name ;
192
193	my $iow = new $CompressClass $name ;
194	print $iow $str ;
195	close $iow;
196
197	my @tmp;
198	my $buf;
199	{
200	my $io = new $UncompressClass $name ;
201
93d092e2 PM	202	ok ! $io->eof, " Not EOF";
93d092e2 PM	203	is $io->tell(), 0, " Tell is 0" ;
1a6a8453	204	my @lines = <$io>;
93d092e2	205	is @lines, 6, " Line is 6"
1a6a8453 PM	206	or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
	207	is $lines[1], "of a paragraph\n" ;
	208	is join('', @lines), $str ;
	209	is $., 6;
	210	is $io->tell(), length($str) ;
	211
	212	ok $io->eof;
	213
	214	ok ! ( defined($io->getline) \|\|
	215	(@tmp = $io->getlines) \|\|
	216	defined(<$io>) \|\|
	217	defined($io->getc) \|\|
	218	read($io, $buf, 100) != 0) ;
	219	}
	220
	221
	222	{
	223	local $/; # slurp mode
	224	my $io = $UncompressClass->new($name);
	225	ok !$io->eof;
	226	my @lines = $io->getlines;
	227	ok $io->eof;
	228	ok @lines == 1 && $lines[0] eq $str;
	229
	230	$io = $UncompressClass->new($name);
	231	ok ! $io->eof;
	232	my $line = <$io>;
	233	ok $line eq $str;
	234	ok $io->eof;
	235	}
	236
	237	{
	238	local $/ = ""; # paragraph mode
	239	my $io = $UncompressClass->new($name);
	240	ok ! $io->eof;
	241	my @lines = <$io>;
	242	ok $io->eof;
	243	ok @lines == 2
	244	or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
	245	ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
	246	or print "# $lines[0]\n";
	247	ok $lines[1] eq "and a single line.\n\n";
	248	}
	249
	250	{
	251	local $/ = "is";
	252	my $io = $UncompressClass->new($name);
	253	my @lines = ();
	254	my $no = 0;
	255	my $err = 0;
	256	ok ! $io->eof;
	257	while (<$io>) {
	258	push(@lines, $_);
	259	$err++ if $. != ++$no;
	260	}
	261
	262	ok $err == 0 ;
	263	ok $io->eof;
	264
	265	ok @lines == 3
	266	or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
	267	ok join("-", @lines) eq
	268	"This- is- an example\n" .
	269	"of a paragraph\n\n\n" .
270	"and a single line.\n\n";
271	}
272
273
274	# Test read
275
276	{
277	my $io = $UncompressClass->new($name);
278
279
280	if (! $BadPerl) {
281	eval { read($io, $buf, -1) } ;
282	like $@, mkErr("length parameter is negative");
283	}
284
285	is read($io, $buf, 0), 0, "Requested 0 bytes" ;
286
287	ok read($io, $buf, 3) == 3 ;
288	ok $buf eq "Thi";
289
290	ok sysread($io, $buf, 3, 2) == 3 ;
291	ok $buf eq "Ths i"
292	or print "# [$buf]\n" ;;
293	ok ! $io->eof;
294
295	# $io->seek(-4, 2);
296	#
297	# ok ! $io->eof;
298	#
299	# ok read($io, $buf, 20) == 4 ;
300	# ok $buf eq "e.\n\n";
301	#
302	# ok read($io, $buf, 20) == 0 ;
303	# ok $buf eq "";
304	#
305	# ok ! $io->eof;
306	}
307
308	}
309
310	{
311	# Read from non-compressed file
312
313	my $str = <<EOT;
314	This is an example
315	of a paragraph
316
317
318	and a single line.
319
320	EOT
321
322	my $lex = new LexFile my $name ;
323
324	writeFile($name, $str);
325	my @tmp;
326	my $buf;
327	{
328	my $io = new $UncompressClass $name, -Transparent => 1 ;
329
330	ok defined $io;
331	ok ! $io->eof;
332	ok $io->tell() == 0 ;
333	my @lines = <$io>;
334	ok @lines == 6;
335	ok $lines[1] eq "of a paragraph\n" ;
336	ok join('', @lines) eq $str ;
337	ok $. == 6;
338	ok $io->tell() == length($str) ;
339
340	ok $io->eof;
341
342	ok ! ( defined($io->getline) \|\|
343	(@tmp = $io->getlines) \|\|
344	defined(<$io>) \|\|
345	defined($io->getc) \|\|
346	read($io, $buf, 100) != 0) ;
347	}
348
349
350	{
351	local $/; # slurp mode
352	my $io = $UncompressClass->new($name);
353	ok ! $io->eof;
354	my @lines = $io->getlines;
355	ok $io->eof;
356	ok @lines == 1 && $lines[0] eq $str;
357
358	$io = $UncompressClass->new($name);
359	ok ! $io->eof;
360	my $line = <$io>;
361	ok $line eq $str;
362	ok $io->eof;
363	}
364
365	{
366	local $/ = ""; # paragraph mode
367	my $io = $UncompressClass->new($name);
368	ok ! $io->eof;
369	my @lines = <$io>;
370	ok $io->eof;
371	ok @lines == 2
372	or print "# exected 2 lines, got " . scalar(@lines) . "\n";
373	ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
374	or print "# [$lines[0]]\n" ;
375	ok $lines[1] eq "and a single line.\n\n";
376	}
377
378	{
379	local $/ = "is";
380	my $io = $UncompressClass->new($name);
381	my @lines = ();
382	my $no = 0;
383	my $err = 0;
384	ok ! $io->eof;
385	while (<$io>) {
386	push(@lines, $_);
387	$err++ if $. != ++$no;
388	}
389
390	ok $err == 0 ;
391	ok $io->eof;
392
393	ok @lines == 3 ;
394	ok join("-", @lines) eq
395	"This- is- an example\n" .
396	"of a paragraph\n\n\n" .
397	"and a single line.\n\n";
398	}
399
400
401	# Test read
402
403	{
404	my $io = $UncompressClass->new($name);
405
406	ok read($io, $buf, 3) == 3 ;
407	ok $buf eq "Thi";
408
409	ok sysread($io, $buf, 3, 2) == 3 ;
410	ok $buf eq "Ths i";
411	ok ! $io->eof;
412
413	# $io->seek(-4, 2);
414	#
415	# ok ! $io->eof;
416	#
417	# ok read($io, $buf, 20) == 4 ;
418	# ok $buf eq "e.\n\n";
419	#
420	# ok read($io, $buf, 20) == 0 ;
421	# ok $buf eq "";
422	#
423	# ok ! $io->eof;
424	}
425
426
427	}
428
429	{
430	# Vary the length parameter in a read
431
432	my $str = <<EOT;
433	x
434	x
435	This is an example
436	of a paragraph
437
438
439	and a single line.
440
441	EOT
442	$str = $str x 100 ;
443
444
445	foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
446	{
447	foreach my $trans (0, 1)
448	{
449	foreach my $append (0, 1)
450	{
451	title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
452
453	my $lex = new LexFile my $name ;
454
455	if ($trans) {
456	writeFile($name, $str) ;
457	}
458	else {
459	my $iow = new $CompressClass $name ;
460	print $iow $str ;
461	close $iow;
462	}
463
464
465	my $io = $UncompressClass->new($name,
466	-Append => $append,
467	-Transparent => $trans);
468
469	my $buf;
470
471	is $io->tell(), 0;
472
473	if ($append) {
474	1 while $io->read($buf, $bufsize) > 0;
475	}
476	else {
477	my $tmp ;
478	$buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
479	}
480	is length $buf, length $str;
481	ok $buf eq $str ;
482	ok ! $io->error() ;
483	ok $io->eof;
484	}
485	}
486	}
487	}
488
489	}
490	}
491
492	1;