X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fwrite.t;h=43c5d72000b4e7cfc3f6db5477ab81f78038dc15;hb=f5b75c1c0ddd0793f7dcbf231d07f72d12d3a088;hp=ae9f8a5b8a3f5fbb3120a7e81a152de1443c0a00;hpb=176ab42ac987e047ebcd48fa0f08231f4084718a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/write.t b/t/op/write.t index ae9f8a5..43c5d72 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -3,6 +3,17 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; +} + +# read in a file +sub cat { + my $file = shift; + local $/; + open my $fh, $file or die "can't open '$file': $!"; + my $data = <$fh>; + close $fh; + $data; } #-- testing numeric fields in all variants (WL) @@ -16,24 +27,24 @@ sub swrite { my @NumTests = ( # [ format, value1, expected1, value2, expected2, .... ] - [ '@###', 0, ' 0', 1, ' 1', 9999.5, '####', - 9999.4999, '9999', -999.5, '####', 1e+100, '####' ], + [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', + 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], - [ '@0##', 0, '0000', 1, '0001', 9999.5, '####', - -999.4999, '-999', -999.5, '####', 1e+100, '####' ], + [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', + -999.4999, '-999', -999.6, '####', 1e+100, '####' ], [ '^###', 0, ' 0', undef, ' ' ], [ '^0##', 0, '0000', undef, ' ' ], - [ '@###.', 0, ' 0.', 1, ' 1.', 9999.5, '#####', - 9999.4999, '9999.', -999.5, '#####' ], + [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', + 9999.4999, '9999.', -999.6, '#####' ], - [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.995, '######', + [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', 999.99499, '999.99', -100, '######' ], [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', - -0.0001, '-00.00' ], + -0.0001, qr/^[\-0]00\.00$/ ], ); @@ -48,13 +59,14 @@ for my $tref ( @NumTests ){ my $bas_tests = 20; # number of tests in section 3 -my $hmb_tests = 36; +my $bug_tests = 4; + +# number of tests in section 4 +my $hmb_tests = 35; -printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests; +my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests; -my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type' - : ($^O eq 'MacOS') ? 'catenate' - : 'cat'; +plan $tests; ############ ## Section 1 @@ -99,7 +111,7 @@ the course of huma... now is the time for all good men to come to\n"; -if (`$CAT Op_write.tmp` eq $right) +if (cat('Op_write.tmp') eq $right) { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 1\n"; } @@ -141,7 +153,7 @@ becomes necessary now is the time for all good men to come to\n"; -if (`$CAT Op_write.tmp` eq $right) +if (cat('Op_write.tmp') eq $right) { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 2\n"; } @@ -185,7 +197,7 @@ becomes necessary now is the time for all good men to come to\n"; -if (`$CAT Op_write.tmp` eq $right) +if (cat('Op_write.tmp') eq $right) { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 3\n"; } @@ -240,7 +252,7 @@ close OUT3 or die "Could not close: $!"; $right = "fit\n"; -if (`$CAT Op_write.tmp` eq $right) +if (cat('Op_write.tmp') eq $right) { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 6\n"; } @@ -268,7 +280,7 @@ format OUT4 = open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; write (OUT4); close OUT4 or die "Could not close: $!"; -if (`$CAT Op_write.tmp` eq "1\n") { +if (cat('Op_write.tmp') eq "1\n") { print "ok 9\n"; 1 while unlink "Op_write.tmp"; } @@ -290,7 +302,7 @@ write(OUT10); close OUT10 or die "Could not close: $!"; $right = " 12.95 00012.95\n"; -if (`$CAT Op_write.tmp` eq $right) +if (cat('Op_write.tmp') eq $right) { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 10\n"; } @@ -316,7 +328,7 @@ $right = "00012.95 1 0# 10 #\n"; -if (`$CAT Op_write.tmp` eq $right) +if (cat('Op_write.tmp') eq $right) { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } else { print "not ok 11\n"; } @@ -334,7 +346,7 @@ $el write(OUT12); } close OUT12 or die "Could not close: $!"; - print `$CAT Op_write.tmp`; + print cat('Op_write.tmp'); } @@ -351,7 +363,7 @@ $v open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT13); close OUT13 or die "Could not close: $!"; - print `$CAT Op_write.tmp`; + print cat('Op_write.tmp'); } { # test 14 @@ -359,7 +371,8 @@ $v # must fail since we have a trailing ; in the eval'ed string (WL) my @v = ('k'); eval "format OUT14 = \n@\n\@v"; - print $@ ? "ok 14\n" : "not ok 14\n"; + print +($@ && $@ =~ /Format not terminated/) + ? "ok 14\n" : "not ok 14 $@\n"; } @@ -375,7 +388,7 @@ $txt open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT15); close OUT15 or die "Could not close: $!"; - my $res = `$CAT Op_write.tmp`; + my $res = cat('Op_write.tmp'); print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n"; } @@ -390,7 +403,7 @@ $txt, $txt open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT16); close OUT16 or die "Could not close: $!"; - my $res = `$CAT Op_write.tmp`; + my $res = cat('Op_write.tmp'); print $res eq <Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT17); close OUT17 or die "Could not close: $!"; - my $res = `$CAT Op_write.tmp`; + my $res = cat('Op_write.tmp'); chomp( $txt ); my $exp = <Op_write.tmp') || die "Can't create Op_write.tmp"; eval { write(OUT18); }; - print $@ ? "ok 18\n" : "not ok 18\n"; + print +($@ && $@ =~ /Repeated format line will never terminate/) + ? "ok 18\n" : "not ok 18: $@\n"; close OUT18 or die "Could not close: $!"; } @@ -438,7 +452,8 @@ EOD '$v' . "\n.\n"; open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT19); - my $res = `$CAT Op_write.tmp`; + close OUT19 or die "Could not close: $!"; + my $res = cat('Op_write.tmp'); print $res eq <Op_write.tmp') || die "Can't create Op_write.tmp"; write(OUT20); - my $res = `$CAT Op_write.tmp`; + close OUT20 or die "Could not close: $!"; + my $res = cat('Op_write.tmp'); print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n"; - -EOD } @@ -486,9 +500,12 @@ for my $tref ( @NumTests ){ my $expected = shift @$tref; my $writeres = swrite( $writefmt, $val ); $nt++; - - print $expected eq $writeres - ? "ok $nt\n" + my $ok = ref($expected) + ? $writeres =~ $expected + : $writeres eq $expected; + + print $ok + ? "ok $nt - $writefmt\n" : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n"; } } @@ -496,31 +513,31 @@ for my $tref ( @NumTests ){ ##################################### ## Section 3 -## Easiest to add new tests above here +## Easiest to add new tests just here ####################################### -# scary format testing from H.Merijn Brand +curr_test($bas_tests + $num_tests + 1); -my $test = $bas_tests + $num_tests + 1; -my $tests = $bas_tests + $num_tests + $hmb_tests; +use strict; # Amazed that this hackery can be made strict ... -if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || - ($^O eq 'os2' and not eval '$OS2::can_fork')) { - foreach ($test..$tests) { - print "ok $_ # skipped: '|-' and '-|' not supported\n"; - } - exit(0); -} +# DAPM. Exercise a couple of error codepaths +{ + local $~ = ''; + eval { write }; + like $@, qr/Not a format reference/, 'format reference'; -use strict; # Amazed that this hackery can be made strict ... + $~ = "NOSUCHFORMAT"; + eval { write }; + like $@, qr/Undefined format/, 'no such format'; +} -# Just a complete test for format, including top-, left- and bottom marging -# and format detection through glob entries format EMPTY = . +my $test = curr_test(); + format Comment = ok @<<<<< $test @@ -532,17 +549,33 @@ $test open STDOUT_DUP, ">&STDOUT"; my $oldfh = select STDOUT_DUP; $= = 10; -{ local $~ = "Comment"; - write; - $test++; - print $- == 9 - ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n"; - $test++; - print $^ eq "STDOUT_DUP_TOP" - ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n"; - $test++; +{ + local $~ = "Comment"; + write; + curr_test($test + 1); + { + local $::TODO = '[ID 20020227.005] format bug with undefined _TOP'; + is $-, 9; + } + is $^, "STDOUT_DUP_TOP"; } select $oldfh; +close STDOUT_DUP; + +# scary format testing from H.Merijn Brand + +# Just a complete test for format, including top-, left- and bottom marging +# and format detection through glob entries + +if (1 || $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || + ($^O eq 'os2' and not eval '$OS2::can_fork')) { + $test = curr_test(); + SKIP: { + skip "'|-' and '-|' not supported", $tests - $test + 1; + } + exit(0); +} + $^ = "STDOUT_TOP"; $= = 7; # Page length @@ -552,19 +585,44 @@ my $tm = 1; # Top margin (empty lines before first output) my $bm = 2; # Bottom marging (empty lines between last text and footer) my $lm = 4; # Left margin (indent in spaces) -select ((select (STDOUT), $| = 1)[0]); -if ($lm > 0 and !open STDOUT, "|-") { # Left margin (in this test ALWAYS set) - select ((select (STDOUT), $| = 1)[0]); +# ----------------------------------------------------------------------- +# +# execute the rest of the script in a child process. The parent reads the +# output from the child and compares it with . + +my @data = ; + +select ((select (STDOUT), $| = 1)[0]); # flush STDOUT + +my $opened = open FROM_CHILD, "-|"; +unless (defined $opened) { + fail "open gave $!"; + exit 0; +} + +if ($opened) { + # in parent here + + pass 'open'; my $s = " " x $lm; - while () { - s/^/$s/; - print + ($_ eq ? "" : "not "), "ok ", $test++, "\n"; + while () { + unless (@data) { + fail 'too much output'; + exit; } - close STDIN; - print + (?"not ":""), "ok ", $test++, "\n"; - close STDOUT; - exit; + s/^/$s/; + my $exp = shift @data; + is $_, $exp; } + close FROM_CHILD; + is "@data", "", "correct length of output"; + exit; +} + +# in child here +$::NO_ENDING = 1; + + select ((select (STDOUT), $| = 1)[0]); $tm = "\n" x $tm; $= -= $bm + 1; # count one for the trailing "----" my $lastmin = 0;