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