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 = 39; 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 my $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 +($@ && $@ =~ /Format not terminated/) 369 ? "ok 14\n" : "not ok 14 $@\n"; 370 371} 372 373{ # test 15 374 # text lost in ^<<< field with \r in value (WL) 375 my $txt = "line 1\rline 2"; 376 format OUT15 = 377^<<<<<<<<<<<<<<<<<< 378$txt 379^<<<<<<<<<<<<<<<<<< 380$txt 381. 382 open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 383 write(OUT15); 384 close OUT15 or die "Could not close: $!"; 385 my $res = cat('Op_write.tmp'); 386 print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n"; 387} 388 389{ # test 16: multiple use of a variable in same line with ^< 390 my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; 391 format OUT16 = 392^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 393$txt, $txt 394^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 395$txt, $txt 396. 397 open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 398 write(OUT16); 399 close OUT16 or die "Could not close: $!"; 400 my $res = cat('Op_write.tmp'); 401 print $res eq <<EOD ? "ok 16\n" : "not ok 16\n"; 402this_is_block_1 this_is_block_2 403this_is_block_3 this_is_block_4 404EOD 405} 406 407{ # test 17: @* "should be on a line of its own", but it should work 408 # cleanly with literals before and after. (WL) 409 410 my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; 411 format OUT17 = 412Here we go: @* That's all, folks! 413 $txt 414. 415 open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 416 write(OUT17); 417 close OUT17 or die "Could not close: $!"; 418 my $res = cat('Op_write.tmp'); 419 chomp( $txt ); 420 my $exp = <<EOD; 421Here we go: $txt That's all, folks! 422EOD 423 print $res eq $exp ? "ok 17\n" : "not ok 17\n"; 424} 425 426{ # test 18: @# and ~~ would cause runaway format, but we now 427 # catch this while compiling (WL) 428 429 format OUT18 = 430@######## ~~ 43110 432. 433 open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 434 eval { write(OUT18); }; 435 print +($@ && $@ =~ /Repeated format line will never terminate/) 436 ? "ok 18\n" : "not ok 18: $@\n"; 437 close OUT18 or die "Could not close: $!"; 438} 439 440{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) 441 my $v = 'gaga'; 442 eval "format OUT19 = \n" . 443 '@<<<' . "\0\n" . 444 '$v' . "\n" . 445 '@<<<' . "\0\n" . 446 '$v' . "\n.\n"; 447 open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 448 write(OUT19); 449 close OUT19 or die "Could not close: $!"; 450 my $res = cat('Op_write.tmp'); 451 print $res eq <<EOD ? "ok 19\n" : "not ok 19\n"; 452gaga\0 453gaga\0 454EOD 455} 456 457{ # test 20: hash accesses; single '}' must not terminate format '}' (WL) 458 my %h = ( xkey => 'xval', ykey => 'yval' ); 459 format OUT20 = 460@>>>> @<<<< ~~ 461each %h 462@>>>> @<<<< 463$h{xkey}, $h{ykey} 464@>>>> @<<<< 465{ $h{xkey}, $h{ykey} 466} 467} 468. 469 my $exp = ''; 470 while( my( $k, $v ) = each( %h ) ){ 471 $exp .= sprintf( "%5s %s\n", $k, $v ); 472 } 473 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 474 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 475 $exp .= "}\n"; 476 open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 477 write(OUT20); 478 close OUT20 or die "Could not close: $!"; 479 my $res = cat('Op_write.tmp'); 480 print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n"; 481} 482 483 484##################### 485## Section 2 486## numeric formatting 487##################### 488 489my $nt = $bas_tests; 490for my $tref ( @NumTests ){ 491 my $writefmt = shift( @$tref ); 492 while (@$tref) { 493 my $val = shift @$tref; 494 my $expected = shift @$tref; 495 my $writeres = swrite( $writefmt, $val ); 496 $nt++; 497 my $ok = ref($expected) 498 ? $writeres =~ $expected 499 : $writeres eq $expected; 500 501 print $ok 502 ? "ok $nt - $writefmt\n" 503 : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n"; 504 } 505} 506 507 508##################################### 509## Section 3 510## Easiest to add new tests above here 511####################################### 512 513# scary format testing from H.Merijn Brand 514 515my $test = $bas_tests + $num_tests + 1; 516my $tests = $bas_tests + $num_tests + $hmb_tests; 517 518if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || 519 ($^O eq 'os2' and not eval '$OS2::can_fork')) { 520 foreach ($test..$tests) { 521 print "ok $_ # skipped: '|-' and '-|' not supported\n"; 522 } 523 exit(0); 524} 525 526 527use strict; # Amazed that this hackery can be made strict ... 528 529# DAPM. Exercise a couple of error codepaths 530 531{ 532 local $~ = ''; 533 eval { write }; 534 print "not " unless $@ and $@ =~ /Not a format reference/; 535 print "ok $test - Not a format reference\n"; 536 $test++; 537 538 $~ = "NOSUCHFORMAT"; 539 eval { write }; 540 print "not " unless $@ and $@ =~ /Undefined format/; 541 print "ok $test - Undefined format\n"; 542 $test++; 543} 544 545# Just a complete test for format, including top-, left- and bottom marging 546# and format detection through glob entries 547 548format EMPTY = 549. 550 551format Comment = 552ok @<<<<< 553$test 554. 555 556 557# [ID 20020227.005] format bug with undefined _TOP 558 559open STDOUT_DUP, ">&STDOUT"; 560my $oldfh = select STDOUT_DUP; 561$= = 10; 562{ local $~ = "Comment"; 563 write; 564 $test++; 565 print $- == 9 566 ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n"; 567 $test++; 568 print $^ eq "STDOUT_DUP_TOP" 569 ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n"; 570 $test++; 571} 572select $oldfh; 573close STDOUT_DUP; 574 575$^ = "STDOUT_TOP"; 576$= = 7; # Page length 577$- = 0; # Lines left 578my $ps = $^L; $^L = ""; # Catch the page separator 579my $tm = 1; # Top margin (empty lines before first output) 580my $bm = 2; # Bottom marging (empty lines between last text and footer) 581my $lm = 4; # Left margin (indent in spaces) 582 583# ----------------------------------------------------------------------- 584# 585# execute the rest of the script in a child process. The parent reads the 586# output from the child and compares it with <DATA>. 587 588my @data = <DATA>; 589 590select ((select (STDOUT), $| = 1)[0]); # flush STDOUT 591 592my $opened = open FROM_CHILD, "-|"; 593unless (defined $opened) { 594 print "not ok $test - open gave $!\n"; exit 0; 595} 596 597if ($opened) { 598 # in parent here 599 600 print "ok $test - open\n"; $test++; 601 my $s = " " x $lm; 602 while (<FROM_CHILD>) { 603 unless (@data) { 604 print "not ok $test - too much output\n"; 605 exit; 606 } 607 s/^/$s/; 608 my $exp = shift @data; 609 print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n"; 610 if ($_ ne $exp) { 611 s/\n/\\n/g for $_, $exp; 612 print "#expected: $exp\n#got: $_\n"; 613 } 614 } 615 close FROM_CHILD; 616 print + (@data?"not ":""), "ok ", $test++, " - too little output\n"; 617 exit; 618} 619 620# in child here 621 622 select ((select (STDOUT), $| = 1)[0]); 623$tm = "\n" x $tm; 624$= -= $bm + 1; # count one for the trailing "----" 625my $lastmin = 0; 626 627my @E; 628 629sub wryte 630{ 631 $lastmin = $-; 632 write; 633 } # wryte; 634 635sub footer 636{ 637 $% == 1 and return ""; 638 639 $lastmin < $= and print "\n" x $lastmin; 640 print "\n" x $bm, "----\n", $ps; 641 $lastmin = $-; 642 ""; 643 } # footer 644 645# Yes, this is sick ;-) 646format TOP = 647@* ~ 648@{[footer]} 649@* ~ 650$tm 651. 652 653format ENTRY = 654@ @<<<<~~ 655@{(shift @E)||["",""]} 656. 657 658format EOR = 659- ----- 660. 661 662sub has_format ($) 663{ 664 my $fmt = shift; 665 exists $::{$fmt} or return 0; 666 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; 667 open my $null, "> /dev/null" or die; 668 my $fh = select $null; 669 local $~ = $fmt; 670 eval "write"; 671 select $fh; 672 $@?0:1; 673 } # has_format 674 675$^ = has_format ("TOP") ? "TOP" : "EMPTY"; 676has_format ("ENTRY") or die "No format defined for ENTRY"; 677foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], 678 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { 679 @E = @$e; 680 local $~ = "ENTRY"; 681 wryte; 682 has_format ("EOR") or next; 683 local $~ = "EOR"; 684 wryte; 685 } 686if (has_format ("EOF")) { 687 local $~ = "EOF"; 688 wryte; 689 } 690 691close STDOUT; 692 693# That was test 48. 694 695__END__ 696 697 1 Test1 698 2 Test2 699 3 Test3 700 701 702 ---- 703 704 4 Test4 705 5 Test5 706 6 Test6 707 708 709 ---- 710 711 7 Test7 712 - ----- 713 714 715 716 ---- 717 718 1 1tseT 719 2 2tseT 720 3 3tseT 721 722 723 ---- 724 725 4 4tseT 726 5 5tseT 727 - ----- 728