1N/A chdir 't' if -d 't'; 1N/A#-- testing numeric fields in all variants (WL) 1N/A local $^A = ""; # don't litter, use a local bin 1N/A # [ format, value1, expected1, value2, expected2, .... ] 1N/A [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', 1N/A 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], 1N/A [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', 1N/A -999.4999, '-999', -999.6, '####', 1e+100, '####' ], 1N/A [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', 1N/A 9999.4999, '9999.', -999.6, '#####' ], 1N/A [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', 1N/A 999.99499, '999.99', -100, '######' ], 1N/A [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', 1N/A -0.0001, qr/^[\-0]00\.00$/ ], 1N/A#--------------------------------------------------------- 1N/A# number of tests in section 1 1N/A# number of tests in section 3 1N/Anow @<<the
@>>>> for all@|||||men to come @<<<< 1N/A 'i' . 's', "time\n", $good, 'to' 1N/Aopen(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/AEND { 1 while unlink 'Op_write.tmp' } 1N/A$multiline = "forescore\nand\nseven years\n"; 1N/A$foo = 'when in the course of human events it becomes necessary'; 1N/Aclose OUT or die "Could not close: $!"; 1N/Anow is the time for all good men to come to\n"; 1N/Aif (cat('Op_write.tmp') eq $right) 1N/A { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } 1N/A { print "not ok 1\n"; } 1N/A$fox = 'wolfishness'; 1N/Amy $fox = 'foxiness'; # Test a lexical variable. 1N/Anow @<<the@>>>> for all@|||||men to come @<<<< 1N/A'i' . 's', "time\n", $good, 'to' 1N/Aopen OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; 1N/A$multiline = "forescore\nand\nseven years\n"; 1N/A$foo = 'when in the course of human events it becomes necessary'; 1N/Aclose OUT2 or die "Could not close: $!"; 1N/Anow is the time for all good men to come to\n"; 1N/Aif (cat('Op_write.tmp') eq $right) 1N/A { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } 1N/A { print "not ok 2\n"; } 1N/Anow @<<the@>>>> for all@|||||men to come @<<<< 1N/A'i' . 's', "time\n", $good, 'to' 1N/Aopen(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A$multiline = "forescore\nand\nseven years\n"; 1N/A$foo = 'when in the course of human events it becomes necessary'; 1N/Aclose OUT2 or die "Could not close: $!"; 1N/Anow is the time for all good men to come to\n"; 1N/Aif (cat('Op_write.tmp') eq $right) 1N/A { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } 1N/A { print "not ok 3\n"; } 1N/A my $format1 = '@' . '>' x $_; 1N/A formline $format1, 'abc'; 1N/A $was1 .= "$format1 $^A\n"; 1N/A local $format2 = '@' . '>' x $_; 1N/A formline $format2, 'abc'; 1N/A $was2 .= "$format2 $^A\n"; 1N/Aprint $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; 1N/Aprint $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; 1N/Aopen(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/Aclose OUT3 or die "Could not close: $!"; 1N/Aif (cat('Op_write.tmp') eq $right) 1N/A { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } 1N/A { print "not ok 6\n"; } 1N/A# test lexicals and globals 1N/A open(LEX, ">&STDOUT") or die; 1N/A close LEX or die "Could not close: $!"; 1N/A# LEX_INTERPNORMAL test 1N/Aopen OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; 1N/Aclose OUT4 or die "Could not close: $!"; 1N/Aif (cat('Op_write.tmp') eq "1\n") { 1N/A 1 while unlink "Op_write.tmp"; 1N/Aopen(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/Aclose OUT10 or die "Could not close: $!"; 1N/A$right = " 12.95 00012.95\n"; 1N/Aif (cat('Op_write.tmp') eq $right) 1N/A { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } 1N/A { print "not ok 10\n"; } 1N/Aopen(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/Aclose OUT11 or die "Could not close: $!"; 1N/Aif (cat('Op_write.tmp') eq $right) 1N/A { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } 1N/A { print "not ok 11\n"; } 1N/Aok ^<<<<<<<<<<<<<<~~ # sv_chop() naze 1N/A my %hash = (12 => 3); 1N/A open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A for $el (keys %hash) { 1N/A close OUT12 or die "Could not close: $!"; 1N/A print cat('Op_write.tmp'); 1N/A # Bug report and testcase by Alexey Tourbin 1N/A tie $v, 'Tie::StdScalar'; 1N/A open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A close OUT13 or die "Could not close: $!"; 1N/A print cat('Op_write.tmp'); 1N/A # Bug #24774 format without trailing \n failed assertion, but this 1N/A # must fail since we have a trailing ; in the eval'ed string (WL) 1N/A eval "format OUT14 = \n@\n\@v"; 1N/A print $@ ? "ok 14\n" : "not ok 14\n"; 1N/A # text lost in ^<<< field with \r in value (WL) 1N/A my $txt = "line 1\rline 2"; 1N/A open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A close OUT15 or die "Could not close: $!"; 1N/A my $res = cat('Op_write.tmp'); 1N/A print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n"; 1N/A{ # test 16: multiple use of a variable in same line with ^< 1N/A my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; 1N/A^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 1N/A^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 1N/A open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A close OUT16 or die "Could not close: $!"; 1N/A my $res = cat('Op_write.tmp'); 1N/A print $res eq <<EOD ? "ok 16\n" : "not ok 16\n"; 1N/Athis_is_block_1 this_is_block_2 1N/Athis_is_block_3 this_is_block_4 1N/A{ # test 17: @* "should be on a line of its own", but it should work 1N/A # cleanly with literals before and after. (WL) 1N/A my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; 1N/AHere we go: @* That's all, folks! 1N/A open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A close OUT17 or die "Could not close: $!"; 1N/A my $res = cat('Op_write.tmp'); 1N/AHere we go: $txt That's all, folks! 1N/A print $res eq $exp ? "ok 17\n" : "not ok 17\n"; 1N/A{ # test 18: @# and ~~ would cause runaway format, but we now 1N/A # catch this while compiling (WL) 1N/A open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A eval { write(OUT18); }; 1N/A print $@ ? "ok 18\n" : "not ok 18\n"; 1N/A close OUT18 or die "Could not close: $!"; 1N/A{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) 1N/A eval "format OUT19 = \n" . 1N/A open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A close OUT19 or die "Could not close: $!"; 1N/A my $res = cat('Op_write.tmp'); 1N/A print $res eq <<EOD ? "ok 19\n" : "not ok 19\n"; 1N/A{ # test 20: hash accesses; single '}' must not terminate format '}' (WL) 1N/A my %h = ( xkey => 'xval', ykey => 'yval' ); 1N/A while( my( $k, $v ) = each( %h ) ){ 1N/A $exp .= sprintf( "%5s %s\n", $k, $v ); 1N/A $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 1N/A $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 1N/A open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1N/A close OUT20 or die "Could not close: $!"; 1N/A my $res = cat('Op_write.tmp'); 1N/A print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n"; 1N/A##################### 1N/A## numeric formatting 1N/A##################### 1N/Afor my $tref ( @NumTests ){ 1N/A my $writefmt = shift( @$tref ); 1N/A my $val = shift @$tref; 1N/A my $expected = shift @$tref; 1N/A my $writeres = swrite( $writefmt, $val ); 1N/A my $ok = ref($expected) 1N/A ? $writeres =~ $expected 1N/A : $writeres eq $expected; 1N/A ? "ok $nt - $writefmt\n" 1N/A : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n"; 1N/A##################################### 1N/A## Easiest to add new tests above here 1N/A####################################### 1N/A# scary format testing from H.Merijn Brand 1N/Amy $test = $bas_tests + $num_tests + 1; 1N/Amy $tests = $bas_tests + $num_tests + $hmb_tests; 1N/Aif ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || 1N/A ($^O eq 'os2' and not eval '$OS2::can_fork')) { 1N/A foreach ($test..$tests) { 1N/A print "ok $_ # skipped: '|-' and '-|' not supported\n"; 1N/Ause strict; # Amazed that this hackery can be made strict ... 1N/A# Just a complete test for format, including top-, left- and bottom marging 1N/A# and format detection through glob entries 1N/A# [ID 20020227.005] format bug with undefined _TOP 1N/Aopen STDOUT_DUP, ">&STDOUT"; 1N/Amy $oldfh = select STDOUT_DUP; 1N/A{ local $~ = "Comment"; 1N/A ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n"; 1N/A print $^ eq "STDOUT_DUP_TOP" 1N/A ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n"; 1N/A$= = 7; # Page length 1N/Amy $ps = $^L; $^L = ""; # Catch the page separator 1N/Amy $tm = 1; # Top margin (empty lines before first output) 1N/Amy $bm = 2; # Bottom marging (empty lines between last text and footer) 1N/Amy $lm = 4; # Left margin (indent in spaces) 1N/A# ----------------------------------------------------------------------- 1N/A# execute the rest of the script in a child process. The parent reads the 1N/A# output from the child and compares it with <DATA>. 1N/Aselect ((select (STDOUT), $| = 1)[0]); # flush STDOUT 1N/Amy $opened = open FROM_CHILD, "-|"; 1N/Aunless (defined $opened) { 1N/A print "not ok $test - open gave $!\n"; exit 0; 1N/A print "ok $test - open\n"; $test++; 1N/A while (<FROM_CHILD>) { 1N/A print "not ok $test - too much output\n"; 1N/A my $exp = shift @data; 1N/A print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n"; 1N/A s/\n/\\n/g for $_, $exp; 1N/A print "#expected: $exp\n#got: $_\n"; 1N/A print + (@data?"not ":""), "ok ", $test++, " - too litle output\n"; 1N/A select ((select (STDOUT), $| = 1)[0]); 1N/A$= -= $bm + 1; # count one for the trailing "----" 1N/A $% == 1 and return ""; 1N/A $lastmin < $= and print "\n" x $lastmin; 1N/A print "\n" x $bm, "----\n", $ps; 1N/A# Yes, this is sick ;-) 1N/A@{(shift @E)||["",""]} 1N/A exists $::{$fmt} or return 0; 1N/A $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; 1N/A open my $null, "> /dev/null" or die; 1N/A my $fh = select $null; 1N/A$^ = has_format ("TOP") ? "TOP" : "EMPTY"; 1N/Ahas_format ("ENTRY") or die "No format defined for ENTRY"; 1N/Aforeach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], 1N/A [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { 1N/A has_format ("EOR") or next; 1N/Aif (has_format ("EOF")) {