1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8# read in a file 9sub cat { 10 my $file = shift; 11 local $/; 12 open my $fh, $file or die "can't open '$file': $!"; 13 my $data = <$fh>; 14 close $fh; 15 $data; 16} 17 18#-- testing numeric fields in all variants (WL) 19 20sub swrite { 21 my $format = shift; 22 local $^A = ""; # don't litter, use a local bin 23 formline( $format, @_ ); 24 return $^A; 25} 26 27my @NumTests = ( 28 # [ format, value1, expected1, value2, expected2, .... ] 29 [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', 30 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], 31 32 [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', 33 -999.4999, '-999', -999.6, '####', 1e+100, '####' ], 34 35 [ '^###', 0, ' 0', undef, ' ' ], 36 37 [ '^0##', 0, '0000', undef, ' ' ], 38 39 [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', 40 9999.4999, '9999.', -999.6, '#####' ], 41 42 [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', 43 999.99499, '999.99', -100, '######' ], 44 45 [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', 46 -0.0001, qr/^[\-0]00\.00$/ ], 47 48); 49 50 51my $num_tests = 0; 52for my $tref ( @NumTests ){ 53 $num_tests += (@$tref - 1)/2; 54} 55#--------------------------------------------------------- 56 57# number of tests in section 1 58my $bas_tests = 20; 59 60# number of tests in section 3 61my $hmb_tests = 37; 62 63printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests; 64 65############ 66## Section 1 67############ 68 69format OUT = 70the quick brown @<< 71$fox 72jumped 73@* 74$multiline 75^<<<<<<<<< 76$foo 77^<<<<<<<<< 78$foo 79^<<<<<<... 80$foo 81now @<<the@>>>> for all@|||||men to come @<<<< 82{ 83 'i' . 's', "time\n", $good, 'to' 84} 85. 86 87open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 88END { 1 while unlink 'Op_write.tmp' } 89 90$fox = 'foxiness'; 91$good = 'good'; 92$multiline = "forescore\nand\nseven years\n"; 93$foo = 'when in the course of human events it becomes necessary'; 94write(OUT); 95close OUT or die "Could not close: $!"; 96 97$right = 98"the quick brown fox 99jumped 100forescore 101and 102seven years 103when in 104the course 105of huma... 106now is the time for all good men to come to\n"; 107 108if (cat('Op_write.tmp') eq $right) 109 { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } 110else 111 { print "not ok 1\n"; } 112 113$fox = 'wolfishness'; 114my $fox = 'foxiness'; # Test a lexical variable. 115 116format OUT2 = 117the quick brown @<< 118$fox 119jumped 120@* 121$multiline 122^<<<<<<<<< ~~ 123$foo 124now @<<the@>>>> for all@|||||men to come @<<<< 125'i' . 's', "time\n", $good, 'to' 126. 127 128open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; 129 130$good = 'good'; 131$multiline = "forescore\nand\nseven years\n"; 132$foo = 'when in the course of human events it becomes necessary'; 133write(OUT2); 134close OUT2 or die "Could not close: $!"; 135 136$right = 137"the quick brown fox 138jumped 139forescore 140and 141seven years 142when in 143the course 144of human 145events it 146becomes 147necessary 148now is the time for all good men to come to\n"; 149 150if (cat('Op_write.tmp') eq $right) 151 { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } 152else 153 { print "not ok 2\n"; } 154 155eval <<'EOFORMAT'; 156format OUT2 = 157the brown quick @<< 158$fox 159jumped 160@* 161$multiline 162and 163^<<<<<<<<< ~~ 164$foo 165now @<<the@>>>> for all@|||||men to come @<<<< 166'i' . 's', "time\n", $good, 'to' 167. 168EOFORMAT 169 170open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 171 172$fox = 'foxiness'; 173$good = 'good'; 174$multiline = "forescore\nand\nseven years\n"; 175$foo = 'when in the course of human events it becomes necessary'; 176write(OUT2); 177close OUT2 or die "Could not close: $!"; 178 179$right = 180"the brown quick fox 181jumped 182forescore 183and 184seven years 185and 186when in 187the course 188of human 189events it 190becomes 191necessary 192now is the time for all good men to come to\n"; 193 194if (cat('Op_write.tmp') eq $right) 195 { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } 196else 197 { print "not ok 3\n"; } 198 199# formline tests 200 201$mustbe = <<EOT; 202@ a 203@> ab 204@>> abc 205@>>> abc 206@>>>> abc 207@>>>>> abc 208@>>>>>> abc 209@>>>>>>> abc 210@>>>>>>>> abc 211@>>>>>>>>> abc 212@>>>>>>>>>> abc 213EOT 214 215$was1 = $was2 = ''; 216for (0..10) { 217 # lexical picture 218 $^A = ''; 219 my $format1 = '@' . '>' x $_; 220 formline $format1, 'abc'; 221 $was1 .= "$format1 $^A\n"; 222 # global 223 $^A = ''; 224 local $format2 = '@' . '>' x $_; 225 formline $format2, 'abc'; 226 $was2 .= "$format2 $^A\n"; 227} 228print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; 229print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; 230 231$^A = ''; 232 233# more test 234 235format OUT3 = 236^<<<<<<... 237$foo 238. 239 240open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 241 242$foo = 'fit '; 243write(OUT3); 244close OUT3 or die "Could not close: $!"; 245 246$right = 247"fit\n"; 248 249if (cat('Op_write.tmp') eq $right) 250 { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } 251else 252 { print "not ok 6\n"; } 253 254# test lexicals and globals 255{ 256 my $this = "ok"; 257 our $that = 7; 258 format LEX = 259@<<@| 260$this,$that 261. 262 open(LEX, ">&STDOUT") or die; 263 write LEX; 264 $that = 8; 265 write LEX; 266 close LEX or die "Could not close: $!"; 267} 268# LEX_INTERPNORMAL test 269my %e = ( a => 1 ); 270format OUT4 = 271@<<<<<< 272"$e{a}" 273. 274open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; 275write (OUT4); 276close OUT4 or die "Could not close: $!"; 277if (cat('Op_write.tmp') eq "1\n") { 278 print "ok 9\n"; 279 1 while unlink "Op_write.tmp"; 280 } 281else { 282 print "not ok 9\n"; 283 } 284 285eval <<'EOFORMAT'; 286format OUT10 = 287@####.## @0###.## 288$test1, $test1 289. 290EOFORMAT 291 292open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 293 294$test1 = 12.95; 295write(OUT10); 296close OUT10 or die "Could not close: $!"; 297 298$right = " 12.95 00012.95\n"; 299if (cat('Op_write.tmp') eq $right) 300 { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } 301else 302 { print "not ok 10\n"; } 303 304eval <<'EOFORMAT'; 305format OUT11 = 306@0###.## 307$test1 308@ 0# 309$test1 310@0 # 311$test1 312. 313EOFORMAT 314 315open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 316 317$test1 = 12.95; 318write(OUT11); 319close OUT11 or die "Could not close: $!"; 320 321$right = 322"00012.95 3231 0# 32410 #\n"; 325if (cat('Op_write.tmp') eq $right) 326 { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } 327else 328 { print "not ok 11\n"; } 329 330{ 331 our $el; 332 format OUT12 = 333ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze 334$el 335. 336 my %hash = (12 => 3); 337 open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 338 339 for $el (keys %hash) { 340 write(OUT12); 341 } 342 close OUT12 or die "Could not close: $!"; 343 print cat('Op_write.tmp'); 344 345} 346 347{ 348 # Bug report and testcase by Alexey Tourbin 349 use Tie::Scalar; 350 my $v; 351 tie $v, 'Tie::StdScalar'; 352 $v = 13; 353 format OUT13 = 354ok ^<<<<<<<<< ~~ 355$v 356. 357 open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 358 write(OUT13); 359 close OUT13 or die "Could not close: $!"; 360 print cat('Op_write.tmp'); 361} 362 363{ # test 14 364 # Bug #24774 format without trailing \n failed assertion, but this 365 # must fail since we have a trailing ; in the eval'ed string (WL) 366 my @v = ('k'); 367 eval "format OUT14 = \n@\n\@v"; 368 print $@ ? "ok 14\n" : "not ok 14\n"; 369 370} 371 372{ # test 15 373 # text lost in ^<<< field with \r in value (WL) 374 my $txt = "line 1\rline 2"; 375 format OUT15 = 376^<<<<<<<<<<<<<<<<<< 377$txt 378^<<<<<<<<<<<<<<<<<< 379$txt 380. 381 open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 382 write(OUT15); 383 close OUT15 or die "Could not close: $!"; 384 my $res = cat('Op_write.tmp'); 385 print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n"; 386} 387 388{ # test 16: multiple use of a variable in same line with ^< 389 my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; 390 format OUT16 = 391^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 392$txt, $txt 393^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 394$txt, $txt 395. 396 open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 397 write(OUT16); 398 close OUT16 or die "Could not close: $!"; 399 my $res = cat('Op_write.tmp'); 400 print $res eq <<EOD ? "ok 16\n" : "not ok 16\n"; 401this_is_block_1 this_is_block_2 402this_is_block_3 this_is_block_4 403EOD 404} 405 406{ # test 17: @* "should be on a line of its own", but it should work 407 # cleanly with literals before and after. (WL) 408 409 my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; 410 format OUT17 = 411Here we go: @* That's all, folks! 412 $txt 413. 414 open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 415 write(OUT17); 416 close OUT17 or die "Could not close: $!"; 417 my $res = cat('Op_write.tmp'); 418 chomp( $txt ); 419 my $exp = <<EOD; 420Here we go: $txt That's all, folks! 421EOD 422 print $res eq $exp ? "ok 17\n" : "not ok 17\n"; 423} 424 425{ # test 18: @# and ~~ would cause runaway format, but we now 426 # catch this while compiling (WL) 427 428 format OUT18 = 429@######## ~~ 43010 431. 432 open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 433 eval { write(OUT18); }; 434 print $@ ? "ok 18\n" : "not ok 18\n"; 435 close OUT18 or die "Could not close: $!"; 436} 437 438{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) 439 my $v = 'gaga'; 440 eval "format OUT19 = \n" . 441 '@<<<' . "\0\n" . 442 '$v' . "\n" . 443 '@<<<' . "\0\n" . 444 '$v' . "\n.\n"; 445 open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 446 write(OUT19); 447 close OUT19 or die "Could not close: $!"; 448 my $res = cat('Op_write.tmp'); 449 print $res eq <<EOD ? "ok 19\n" : "not ok 19\n"; 450gaga\0 451gaga\0 452EOD 453} 454 455{ # test 20: hash accesses; single '}' must not terminate format '}' (WL) 456 my %h = ( xkey => 'xval', ykey => 'yval' ); 457 format OUT20 = 458@>>>> @<<<< ~~ 459each %h 460@>>>> @<<<< 461$h{xkey}, $h{ykey} 462@>>>> @<<<< 463{ $h{xkey}, $h{ykey} 464} 465} 466. 467 my $exp = ''; 468 while( my( $k, $v ) = each( %h ) ){ 469 $exp .= sprintf( "%5s %s\n", $k, $v ); 470 } 471 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 472 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 473 $exp .= "}\n"; 474 open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 475 write(OUT20); 476 close OUT20 or die "Could not close: $!"; 477 my $res = cat('Op_write.tmp'); 478 print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n"; 479} 480 481 482##################### 483## Section 2 484## numeric formatting 485##################### 486 487my $nt = $bas_tests; 488for my $tref ( @NumTests ){ 489 my $writefmt = shift( @$tref ); 490 while (@$tref) { 491 my $val = shift @$tref; 492 my $expected = shift @$tref; 493 my $writeres = swrite( $writefmt, $val ); 494 $nt++; 495 my $ok = ref($expected) 496 ? $writeres =~ $expected 497 : $writeres eq $expected; 498 499 print $ok 500 ? "ok $nt - $writefmt\n" 501 : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n"; 502 } 503} 504 505 506##################################### 507## Section 3 508## Easiest to add new tests above here 509####################################### 510 511# scary format testing from H.Merijn Brand 512 513my $test = $bas_tests + $num_tests + 1; 514my $tests = $bas_tests + $num_tests + $hmb_tests; 515 516if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || 517 ($^O eq 'os2' and not eval '$OS2::can_fork')) { 518 foreach ($test..$tests) { 519 print "ok $_ # skipped: '|-' and '-|' not supported\n"; 520 } 521 exit(0); 522} 523 524 525use strict; # Amazed that this hackery can be made strict ... 526 527# Just a complete test for format, including top-, left- and bottom marging 528# and format detection through glob entries 529 530format EMPTY = 531. 532 533format Comment = 534ok @<<<<< 535$test 536. 537 538 539# [ID 20020227.005] format bug with undefined _TOP 540 541open STDOUT_DUP, ">&STDOUT"; 542my $oldfh = select STDOUT_DUP; 543$= = 10; 544{ local $~ = "Comment"; 545 write; 546 $test++; 547 print $- == 9 548 ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n"; 549 $test++; 550 print $^ eq "STDOUT_DUP_TOP" 551 ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n"; 552 $test++; 553} 554select $oldfh; 555close STDOUT_DUP; 556 557$^ = "STDOUT_TOP"; 558$= = 7; # Page length 559$- = 0; # Lines left 560my $ps = $^L; $^L = ""; # Catch the page separator 561my $tm = 1; # Top margin (empty lines before first output) 562my $bm = 2; # Bottom marging (empty lines between last text and footer) 563my $lm = 4; # Left margin (indent in spaces) 564 565# ----------------------------------------------------------------------- 566# 567# execute the rest of the script in a child process. The parent reads the 568# output from the child and compares it with <DATA>. 569 570my @data = <DATA>; 571 572select ((select (STDOUT), $| = 1)[0]); # flush STDOUT 573 574my $opened = open FROM_CHILD, "-|"; 575unless (defined $opened) { 576 print "not ok $test - open gave $!\n"; exit 0; 577} 578 579if ($opened) { 580 # in parent here 581 582 print "ok $test - open\n"; $test++; 583 my $s = " " x $lm; 584 while (<FROM_CHILD>) { 585 unless (@data) { 586 print "not ok $test - too much output\n"; 587 exit; 588 } 589 s/^/$s/; 590 my $exp = shift @data; 591 print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n"; 592 if ($_ ne $exp) { 593 s/\n/\\n/g for $_, $exp; 594 print "#expected: $exp\n#got: $_\n"; 595 } 596 } 597 close FROM_CHILD; 598 print + (@data?"not ":""), "ok ", $test++, " - too litle output\n"; 599 exit; 600} 601 602# in child here 603 604 select ((select (STDOUT), $| = 1)[0]); 605$tm = "\n" x $tm; 606$= -= $bm + 1; # count one for the trailing "----" 607my $lastmin = 0; 608 609my @E; 610 611sub wryte 612{ 613 $lastmin = $-; 614 write; 615 } # wryte; 616 617sub footer 618{ 619 $% == 1 and return ""; 620 621 $lastmin < $= and print "\n" x $lastmin; 622 print "\n" x $bm, "----\n", $ps; 623 $lastmin = $-; 624 ""; 625 } # footer 626 627# Yes, this is sick ;-) 628format TOP = 629@* ~ 630@{[footer]} 631@* ~ 632$tm 633. 634 635format ENTRY = 636@ @<<<<~~ 637@{(shift @E)||["",""]} 638. 639 640format EOR = 641- ----- 642. 643 644sub has_format ($) 645{ 646 my $fmt = shift; 647 exists $::{$fmt} or return 0; 648 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; 649 open my $null, "> /dev/null" or die; 650 my $fh = select $null; 651 local $~ = $fmt; 652 eval "write"; 653 select $fh; 654 $@?0:1; 655 } # has_format 656 657$^ = has_format ("TOP") ? "TOP" : "EMPTY"; 658has_format ("ENTRY") or die "No format defined for ENTRY"; 659foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], 660 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { 661 @E = @$e; 662 local $~ = "ENTRY"; 663 wryte; 664 has_format ("EOR") or next; 665 local $~ = "EOR"; 666 wryte; 667 } 668if (has_format ("EOF")) { 669 local $~ = "EOF"; 670 wryte; 671 } 672 673close STDOUT; 674 675# That was test 48. 676 677__END__ 678 679 1 Test1 680 2 Test2 681 3 Test3 682 683 684 ---- 685 686 4 Test4 687 5 Test5 688 6 Test6 689 690 691 ---- 692 693 7 Test7 694 - ----- 695 696 697 698 ---- 699 700 1 1tseT 701 2 2tseT 702 3 3tseT 703 704 705 ---- 706 707 4 4tseT 708 5 5tseT 709 - ----- 710