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

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

use Test::More ;
use CompTestUtils;

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

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

    if ($BadPerl) {
        $tests = 78 ;
    }
    else {
        $tests = 84 ;
    }

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

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

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

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