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 = 21; 62 63# number of tests in section 3 64my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11; 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 { unlink_all '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 unlink_all '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 unlink_all '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 unlink_all '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 unlink_all '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 unlink_all "Op_write.tmp"; 280 281# More LEX_INTERPNORMAL 282format OUT4a= 283@<<<<<<<<<<<<<<< 284"${; use 285 strict; \'Nasdaq dropping like flies'}" 286. 287open OUT4a, ">Op_write.tmp" or die "Can't create Op_write.tmp"; 288write (OUT4a); 289close OUT4a or die "Could not close: $!"; 290is cat('Op_write.tmp'), "Nasdaq dropping\n", 'skipspace inside "${...}"' 291 and unlink_all "Op_write.tmp"; 292 293eval <<'EOFORMAT'; 294format OUT10 = 295@####.## @0###.## 296$test1, $test1 297. 298EOFORMAT 299 300open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 301 302use vars '$test1'; 303$test1 = 12.95; 304write(OUT10); 305close OUT10 or die "Could not close: $!"; 306 307$right = " 12.95 00012.95\n"; 308is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; 309 310eval <<'EOFORMAT'; 311format OUT11 = 312@0###.## 313$test1 314@ 0# 315$test1 316@0 # 317$test1 318. 319EOFORMAT 320 321open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 322 323$test1 = 12.95; 324write(OUT11); 325close OUT11 or die "Could not close: $!"; 326 327$right = 328"00012.95 3291 0# 33010 #\n"; 331is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; 332 333{ 334 my $test = curr_test(); 335 my $el; 336 format OUT12 = 337ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze 338$el 339. 340 my %hash = ($test => 3); 341 open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 342 343 for $el (keys %hash) { 344 write(OUT12); 345 } 346 close OUT12 or die "Could not close: $!"; 347 print cat('Op_write.tmp'); 348 curr_test($test + 1); 349} 350 351{ 352 my $test = curr_test(); 353 # Bug report and testcase by Alexey Tourbin 354 use Tie::Scalar; 355 my $v; 356 tie $v, 'Tie::StdScalar'; 357 $v = $test; 358 format OUT13 = 359ok ^<<<<<<<<< ~~ 360$v 361. 362 open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 363 write(OUT13); 364 close OUT13 or die "Could not close: $!"; 365 print cat('Op_write.tmp'); 366 curr_test($test + 1); 367} 368 369{ # test 14 370 # Bug #24774 format without trailing \n failed assertion, but this 371 # must fail since we have a trailing ; in the eval'ed string (WL) 372 my @v = ('k'); 373 eval "format OUT14 = \n@\n\@v"; 374 like $@, qr/Format not terminated/; 375} 376 377{ # test 15 378 # text lost in ^<<< field with \r in value (WL) 379 my $txt = "line 1\rline 2"; 380 format OUT15 = 381^<<<<<<<<<<<<<<<<<< 382$txt 383^<<<<<<<<<<<<<<<<<< 384$txt 385. 386 open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 387 write(OUT15); 388 close OUT15 or die "Could not close: $!"; 389 my $res = cat('Op_write.tmp'); 390 is $res, "line 1\nline 2\n"; 391} 392 393{ # test 16: multiple use of a variable in same line with ^< 394 my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; 395 format OUT16 = 396^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 397$txt, $txt 398^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 399$txt, $txt 400. 401 open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 402 write(OUT16); 403 close OUT16 or die "Could not close: $!"; 404 my $res = cat('Op_write.tmp'); 405 is $res, <<EOD; 406this_is_block_1 this_is_block_2 407this_is_block_3 this_is_block_4 408EOD 409} 410 411{ # test 17: @* "should be on a line of its own", but it should work 412 # cleanly with literals before and after. (WL) 413 414 my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; 415 format OUT17 = 416Here we go: @* That's all, folks! 417 $txt 418. 419 open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 420 write(OUT17); 421 close OUT17 or die "Could not close: $!"; 422 my $res = cat('Op_write.tmp'); 423 chomp( $txt ); 424 my $exp = <<EOD; 425Here we go: $txt That's all, folks! 426EOD 427 is $res, $exp; 428} 429 430{ # test 18: @# and ~~ would cause runaway format, but we now 431 # catch this while compiling (WL) 432 433 format OUT18 = 434@######## ~~ 43510 436. 437 open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 438 eval { write(OUT18); }; 439 like $@, qr/Repeated format line will never terminate/; 440 close OUT18 or die "Could not close: $!"; 441} 442 443{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) 444 my $v = 'gaga'; 445 eval "format OUT19 = \n" . 446 '@<<<' . "\0\n" . 447 '$v' . "\n" . 448 '@<<<' . "\0\n" . 449 '$v' . "\n.\n"; 450 open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 451 write(OUT19); 452 close OUT19 or die "Could not close: $!"; 453 my $res = cat('Op_write.tmp'); 454 is $res, <<EOD; 455gaga\0 456gaga\0 457EOD 458} 459 460{ # test 20: hash accesses; single '}' must not terminate format '}' (WL) 461 my %h = ( xkey => 'xval', ykey => 'yval' ); 462 format OUT20 = 463@>>>> @<<<< ~~ 464each %h 465@>>>> @<<<< 466$h{xkey}, $h{ykey} 467@>>>> @<<<< 468{ $h{xkey}, $h{ykey} 469} 470} 471. 472 my $exp = ''; 473 while( my( $k, $v ) = each( %h ) ){ 474 $exp .= sprintf( "%5s %s\n", $k, $v ); 475 } 476 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 477 $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 478 $exp .= "}\n"; 479 open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 480 write(OUT20); 481 close OUT20 or die "Could not close: $!"; 482 my $res = cat('Op_write.tmp'); 483 is $res, $exp; 484} 485 486 487##################### 488## Section 2 489## numeric formatting 490##################### 491 492curr_test($bas_tests + 1); 493 494for my $tref ( @NumTests ){ 495 my $writefmt = shift( @$tref ); 496 while (@$tref) { 497 my $val = shift @$tref; 498 my $expected = shift @$tref; 499 my $writeres = swrite( $writefmt, $val ); 500 if (ref $expected) { 501 like $writeres, $expected, $writefmt; 502 } else { 503 is $writeres, $expected, $writefmt; 504 } 505 } 506} 507 508 509##################################### 510## Section 3 511## Easiest to add new tests just here 512##################################### 513 514# DAPM. Exercise a couple of error codepaths 515 516{ 517 local $~ = ''; 518 eval { write }; 519 like $@, qr/Undefined format ""/, 'format with 0-length name'; 520 521 $~ = "\0foo"; 522 eval { write }; 523 like $@, qr/Undefined format "\0foo"/, 524 'no such format beginning with null'; 525 526 $~ = "NOSUCHFORMAT"; 527 eval { write }; 528 like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format'; 529} 530 531select +(select(OUT21), do { 532 open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 533 534 format OUT21 = 535@<< 536$_ 537. 538 539 local $^ = ''; 540 local $= = 1; 541 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; 542 like $@, qr/Undefined top format ""/, 'top format with 0-length name'; 543 544 $^ = "\0foo"; 545 # For some reason, we have to do this twice to get the error again. 546 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; 547 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; 548 like $@, qr/Undefined top format "\0foo"/, 549 'no such top format beginning with null'; 550 551 $^ = "NOSUCHFORMAT"; 552 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; 553 $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; 554 like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format'; 555 556 # reset things; 557 eval { write(OUT21) }; 558 undef $^A; 559 560 close OUT21 or die "Could not close: $!"; 561})[0]; 562 563{ 564 package Count; 565 566 sub TIESCALAR { 567 my $class = shift; 568 bless [shift, 0, 0], $class; 569 } 570 571 sub FETCH { 572 my $self = shift; 573 ++$self->[1]; 574 $self->[0]; 575 } 576 577 sub STORE { 578 my $self = shift; 579 ++$self->[2]; 580 $self->[0] = shift; 581 } 582} 583 584{ 585 my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a} 586 my ($pound, $pm) = ("\xA3", "\xB1"); 587 588 foreach my $first ('N', $pound, $pound_utf8) { 589 foreach my $base ('N', $pm, $pm_utf8) { 590 foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n", 591 "$base\nMoo!\n",) { 592 foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) { 593 my ($format, $re) = @$_; 594 $format = "1^*2 3${format}4"; 595 foreach my $class ('', 'Count') { 596 my $name = qq{swrite("$format", "$first", "$second") class="$class"}; 597 $name =~ s/\n/\\n/g; 598 $name =~ s{(.)}{ 599 ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1 600 }ge; 601 602 $first =~ /(.+)/ or die $first; 603 my $expect = "1${1}2"; 604 $second =~ $re or die $second; 605 $expect .= " 3${1}4"; 606 607 if ($class) { 608 my $copy1 = $first; 609 my $copy2; 610 tie $copy2, $class, $second; 611 is swrite("$format", $copy1, $copy2), $expect, $name; 612 my $obj = tied $copy2; 613 is $obj->[1], 1, 'value read exactly once'; 614 } else { 615 my ($copy1, $copy2) = ($first, $second); 616 is swrite("$format", $copy1, $copy2), $expect, $name; 617 } 618 } 619 } 620 } 621 } 622 } 623} 624 625{ 626 # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because 627 # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will 628 # be doing something similarly out of bounds on everything from 5.000 629 my $ref = []; 630 is swrite('>^*<', $ref), ">$ref<"; 631 is swrite('>@*<', $ref), ">$ref<"; 632} 633 634format EMPTY = 635. 636 637my $test = curr_test(); 638 639format Comment = 640ok @<<<<< 641$test 642. 643 644 645# RT #8698 format bug with undefined _TOP 646 647open STDOUT_DUP, ">&STDOUT"; 648my $oldfh = select STDOUT_DUP; 649$= = 10; 650{ 651 local $~ = "Comment"; 652 write; 653 curr_test($test + 1); 654 is $-, 9; 655 is $^, "STDOUT_DUP_TOP"; 656} 657select $oldfh; 658close STDOUT_DUP; 659 660*CmT = *{$::{Comment}}{FORMAT}; 661ok defined *{$::{CmT}}{FORMAT}, "glob assign"; 662 663 664# RT #91032: Check that "non-real" strings like tie and overload work, 665# especially that they re-compile the pattern on each FETCH, and that 666# they don't overrun the buffer 667 668 669{ 670 package RT91032; 671 672 sub TIESCALAR { bless [] } 673 my $i = 0; 674 sub FETCH { $i++; "A$i @> Z\n" } 675 676 use overload '""' => \&FETCH; 677 678 tie my $f, 'RT91032'; 679 680 formline $f, "a"; 681 formline $f, "bc"; 682 ::is $^A, "A1 a Z\nA2 bc Z\n", "RT 91032: tied"; 683 $^A = ''; 684 685 my $g = bless []; # has overloaded stringify 686 formline $g, "de"; 687 formline $g, "f"; 688 ::is $^A, "A3 de Z\nA4 f Z\n", "RT 91032: overloaded"; 689 $^A = ''; 690 691 my $h = []; 692 formline $h, "junk1"; 693 formline $h, "junk2"; 694 ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref"; 695 ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok"; 696 ::is $^A, "$h$h","RT 91032: stringified array"; 697 $^A = ''; 698 699 # used to overwrite the ~~ in the *original SV with spaces. Naughty! 700 701 my $orig = my $format = "^<<<<< ~~\n"; 702 my $abc = "abc"; 703 formline $format, $abc; 704 $^A =''; 705 ::is $format, $orig, "RT91032: don't overwrite orig format string"; 706 707 # check that ~ and ~~ are displayed correctly as whitespace, 708 # under the influence of various different types of border 709 710 for my $n (1,2) { 711 for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') { 712 for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') { 713 my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n"; 714 my $sfmt = ($fmt =~ s/~/ /gr); 715 my ($a, $bc, $stop); 716 ($a, $bc, $stop) = ('a', 'bc', 's'); 717 # $stop is to stop '~~' deleting the whole line 718 formline $sfmt, $stop, $a, $bc; 719 my $exp = $^A; 720 $^A = ''; 721 ($a, $bc, $stop) = ('a', 'bc', 's'); 722 formline $fmt, $stop, $a, $bc; 723 my $got = $^A; 724 $^A = ''; 725 $fmt =~ s/\n/\\n/; 726 ::is($got, $exp, "chop munging: [$fmt]"); 727 } 728 } 729 } 730} 731 732# check that '~ (delete current line if empty) works when 733# the target gets upgraded to uft8 (and re-allocated) midstream. 734 735{ 736 my $format = "\x{100}@~\n"; # format is utf8 737 # this target is not utf8, but will expand (and get reallocated) 738 # when upgraded to utf8. 739 my $orig = "\x80\x81\x82"; 740 local $^A = $orig; 741 my $empty = ""; 742 formline $format, $empty; 743 is $^A , $orig, "~ and realloc"; 744 745 # check similarly that trailing blank removal works ok 746 747 $format = "@<\n\x{100}"; # format is utf8 748 chop $format; 749 $orig = " "; 750 $^A = $orig; 751 formline $format, " "; 752 is $^A, "$orig\n", "end-of-line blanks and realloc"; 753 754 # and check this doesn't overflow the buffer 755 756 local $^A = ''; 757 $format = "@* @####\n"; 758 $orig = "x" x 100 . "\n"; 759 formline $format, $orig, 12345; 760 is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow"; 761 762 # make sure it can cope with formats > 64k 763 764 $format = 'x' x 65537; 765 $^A = ''; 766 formline $format; 767 # don't use 'is' here, as the diag output will be too long! 768 ok $^A eq $format, ">64K"; 769} 770 771 772SKIP: { 773 skip_if_miniperl('miniperl does not support scalario'); 774 my $buf = ""; 775 open my $fh, ">", \$buf; 776 my $old_fh = select $fh; 777 local $~ = "CmT"; 778 write; 779 select $old_fh; 780 close $fh; 781 is $buf, "ok $test\n", "write to duplicated format"; 782} 783 784format caret_A_test_TOP = 785T 786. 787 788format caret_A_test = 789L1 790L2 791L3 792L4 793. 794 795SKIP: { 796 skip_if_miniperl('miniperl does not support scalario'); 797 my $buf = ""; 798 open my $fh, ">", \$buf; 799 my $old_fh = select $fh; 800 local $^ = "caret_A_test_TOP"; 801 local $~ = "caret_A_test"; 802 local $= = 3; 803 local $^A = "A1\nA2\nA3\nA4\n"; 804 write; 805 select $old_fh; 806 close $fh; 807 is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n", 808 "assign to ^A sets FmLINES"; 809} 810 811fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings'); 812#!./perl 813 814use strict; 815use warnings; # crashes! 816 817format = 818. 819 820write; 821 822format = 823. 824 825write; 826EOP 827 828fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments'); 829use strict; 830use warnings; 831my $zamm = ['crunch_eth']; 832formline $zamm; 833printf ">%s<\n", ref $zamm; 834print "$zamm->[0]\n"; 835EOP 836 837# [perl #73690] 838 839select +(select(RT73690), do { 840 open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 841 format RT73690 = 842@<< @<< 84311, 22 844. 845 846 my @ret; 847 848 @ret = write; 849 is(scalar(@ret), 1); 850 ok($ret[0]); 851 @ret = scalar(write); 852 is(scalar(@ret), 1); 853 ok($ret[0]); 854 @ret = write(RT73690); 855 is(scalar(@ret), 1); 856 ok($ret[0]); 857 @ret = scalar(write(RT73690)); 858 is(scalar(@ret), 1); 859 ok($ret[0]); 860 861 @ret = ('a', write, 'z'); 862 is(scalar(@ret), 3); 863 is($ret[0], 'a'); 864 ok($ret[1]); 865 is($ret[2], 'z'); 866 @ret = ('b', scalar(write), 'y'); 867 is(scalar(@ret), 3); 868 is($ret[0], 'b'); 869 ok($ret[1]); 870 is($ret[2], 'y'); 871 @ret = ('c', write(RT73690), 'x'); 872 is(scalar(@ret), 3); 873 is($ret[0], 'c'); 874 ok($ret[1]); 875 is($ret[2], 'x'); 876 @ret = ('d', scalar(write(RT73690)), 'w'); 877 is(scalar(@ret), 3); 878 is($ret[0], 'd'); 879 ok($ret[1]); 880 is($ret[2], 'w'); 881 882 @ret = do { write; 'foo' }; 883 is(scalar(@ret), 1); 884 is($ret[0], 'foo'); 885 @ret = do { scalar(write); 'bar' }; 886 is(scalar(@ret), 1); 887 is($ret[0], 'bar'); 888 @ret = do { write(RT73690); 'baz' }; 889 is(scalar(@ret), 1); 890 is($ret[0], 'baz'); 891 @ret = do { scalar(write(RT73690)); 'quux' }; 892 is(scalar(@ret), 1); 893 is($ret[0], 'quux'); 894 895 @ret = ('a', do { write; 'foo' }, 'z'); 896 is(scalar(@ret), 3); 897 is($ret[0], 'a'); 898 is($ret[1], 'foo'); 899 is($ret[2], 'z'); 900 @ret = ('b', do { scalar(write); 'bar' }, 'y'); 901 is(scalar(@ret), 3); 902 is($ret[0], 'b'); 903 is($ret[1], 'bar'); 904 is($ret[2], 'y'); 905 @ret = ('c', do { write(RT73690); 'baz' }, 'x'); 906 is(scalar(@ret), 3); 907 is($ret[0], 'c'); 908 is($ret[1], 'baz'); 909 is($ret[2], 'x'); 910 @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w'); 911 is(scalar(@ret), 3); 912 is($ret[0], 'd'); 913 is($ret[1], 'quux'); 914 is($ret[2], 'w'); 915 916 close RT73690 or die "Could not close: $!"; 917})[0]; 918 919select +(select(RT73690_2), do { 920 open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 921 format RT73690_2 = 922@<< @<< 923return 924. 925 926 my @ret; 927 928 @ret = write; 929 is(scalar(@ret), 1); 930 ok(!$ret[0]); 931 @ret = scalar(write); 932 is(scalar(@ret), 1); 933 ok(!$ret[0]); 934 @ret = write(RT73690_2); 935 is(scalar(@ret), 1); 936 ok(!$ret[0]); 937 @ret = scalar(write(RT73690_2)); 938 is(scalar(@ret), 1); 939 ok(!$ret[0]); 940 941 @ret = ('a', write, 'z'); 942 is(scalar(@ret), 3); 943 is($ret[0], 'a'); 944 ok(!$ret[1]); 945 is($ret[2], 'z'); 946 @ret = ('b', scalar(write), 'y'); 947 is(scalar(@ret), 3); 948 is($ret[0], 'b'); 949 ok(!$ret[1]); 950 is($ret[2], 'y'); 951 @ret = ('c', write(RT73690_2), 'x'); 952 is(scalar(@ret), 3); 953 is($ret[0], 'c'); 954 ok(!$ret[1]); 955 is($ret[2], 'x'); 956 @ret = ('d', scalar(write(RT73690_2)), 'w'); 957 is(scalar(@ret), 3); 958 is($ret[0], 'd'); 959 ok(!$ret[1]); 960 is($ret[2], 'w'); 961 962 @ret = do { write; 'foo' }; 963 is(scalar(@ret), 1); 964 is($ret[0], 'foo'); 965 @ret = do { scalar(write); 'bar' }; 966 is(scalar(@ret), 1); 967 is($ret[0], 'bar'); 968 @ret = do { write(RT73690_2); 'baz' }; 969 is(scalar(@ret), 1); 970 is($ret[0], 'baz'); 971 @ret = do { scalar(write(RT73690_2)); 'quux' }; 972 is(scalar(@ret), 1); 973 is($ret[0], 'quux'); 974 975 @ret = ('a', do { write; 'foo' }, 'z'); 976 is(scalar(@ret), 3); 977 is($ret[0], 'a'); 978 is($ret[1], 'foo'); 979 is($ret[2], 'z'); 980 @ret = ('b', do { scalar(write); 'bar' }, 'y'); 981 is(scalar(@ret), 3); 982 is($ret[0], 'b'); 983 is($ret[1], 'bar'); 984 is($ret[2], 'y'); 985 @ret = ('c', do { write(RT73690_2); 'baz' }, 'x'); 986 is(scalar(@ret), 3); 987 is($ret[0], 'c'); 988 is($ret[1], 'baz'); 989 is($ret[2], 'x'); 990 @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w'); 991 is(scalar(@ret), 3); 992 is($ret[0], 'd'); 993 is($ret[1], 'quux'); 994 is($ret[2], 'w'); 995 996 close RT73690_2 or die "Could not close: $!"; 997})[0]; 998 999open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1000select +(select(UNDEF), $~ = "UNDEFFORMAT")[0]; 1001format UNDEFFORMAT = 1002@ 1003undef *UNDEFFORMAT 1004. 1005write UNDEF; 1006pass "active format cannot be freed"; 1007 1008select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0]; 1009format UNDEFFORMAT2 = 1010@ 1011close UNDEF or die "Could not close: $!"; undef *UNDEF 1012. 1013write UNDEF; 1014pass "freeing current handle in format"; 1015undef $^A; 1016 1017ok !eval q| 1018format foo { 1019@<<< 1020$a 1021} 1022;1 1023|, 'format foo { ... } is not allowed'; 1024 1025ok !eval q| 1026format = 1027@<<< 1028} 1029;1 1030|, 'format = ... } is not allowed'; 1031 1032open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1033format NEST = 1034@<<< 1035{ 1036 my $birds = "birds"; 1037 local *NEST = *BIRDS{FORMAT}; 1038 write NEST; 1039 format BIRDS = 1040@<<<<< 1041$birds; 1042. 1043 "nest" 1044} 1045. 1046write NEST; 1047close NEST or die "Could not close: $!"; 1048is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats'; 1049 1050# A compilation error should not create a format 1051eval q| 1052format ERROR = 1053@ 1054@_ =~ s/// 1055. 1056|; 1057eval { write ERROR }; 1058like $@, qr'Undefined format', 1059 'formats with compilation errors are not created'; 1060 1061# This syntax error used to cause a crash, double free, or a least 1062# a bad read. 1063# See the long-winded explanation at: 1064# https://rt.perl.org/rt3/Ticket/Display.html?id=43425#txn-1144500 1065eval q| 1066format = 1067@ 1068use;format 1069strict 1070. 1071|; 1072pass('no crash with invalid use/format inside format'); 1073 1074 1075# Low-precedence operators on argument line 1076format AND = 1077@ 10780 and die 1079. 1080$- = $=; 1081ok eval { local $~ = "AND"; print "# "; write; 1 }, 1082 "low-prec ops on arg line" or diag $@; 1083 1084# Anonymous hashes 1085open(HASH, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1086format HASH = 1087@<<< 1088${{qw[ Sun 0 Mon 1 Tue 2 Wed 3 Thu 4 Fri 5 Sat 6 ]}}{"Wed"} 1089. 1090write HASH; 1091close HASH or die "Could not close: $!"; 1092is cat('Op_write.tmp'), "3\n", 'anonymous hashes'; 1093 1094# pragmata inside argument line 1095open(STRICT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 1096format STRICT = 1097@<<< 1098no strict; $foo 1099. 1100$::foo = 'oof::$'; 1101write STRICT; 1102close STRICT or die "Could not close: $!"; 1103is cat('Op_write.tmp'), "oof:\n", 'pragmata on format line'; 1104 1105SKIP: { 1106 skip "no weak refs" unless eval { require Scalar::Util }; 1107 sub Potshriggley { 1108format Potshriggley = 1109. 1110 } 1111 Scalar::Util::weaken(my $x = *Potshriggley{FORMAT}); 1112 undef *Potshriggley; 1113 is $x, undef, 'formats in subs do not leak'; 1114} 1115 1116 1117############################# 1118## Section 4 1119## Add new tests *above* here 1120############################# 1121 1122# scary format testing from H.Merijn Brand 1123 1124# Just a complete test for format, including top-, left- and bottom marging 1125# and format detection through glob entries 1126 1127if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || 1128 ($^O eq 'os2' and not eval '$OS2::can_fork')) { 1129 $test = curr_test(); 1130 SKIP: { 1131 skip "'|-' and '-|' not supported", $tests - $test + 1; 1132 } 1133 exit(0); 1134} 1135 1136 1137$^ = "STDOUT_TOP"; 1138$= = 7; # Page length 1139$- = 0; # Lines left 1140my $ps = $^L; $^L = ""; # Catch the page separator 1141my $tm = 1; # Top margin (empty lines before first output) 1142my $bm = 2; # Bottom marging (empty lines between last text and footer) 1143my $lm = 4; # Left margin (indent in spaces) 1144 1145# ----------------------------------------------------------------------- 1146# 1147# execute the rest of the script in a child process. The parent reads the 1148# output from the child and compares it with <DATA>. 1149 1150my @data = <DATA>; 1151 1152select ((select (STDOUT), $| = 1)[0]); # flush STDOUT 1153 1154my $opened = open FROM_CHILD, "-|"; 1155unless (defined $opened) { 1156 fail "open gave $!"; 1157 exit 0; 1158} 1159 1160if ($opened) { 1161 # in parent here 1162 1163 pass 'open'; 1164 my $s = " " x $lm; 1165 while (<FROM_CHILD>) { 1166 unless (@data) { 1167 fail 'too much output'; 1168 exit; 1169 } 1170 s/^/$s/; 1171 my $exp = shift @data; 1172 is $_, $exp; 1173 } 1174 close FROM_CHILD; 1175 is "@data", "", "correct length of output"; 1176 exit; 1177} 1178 1179# in child here 1180$::NO_ENDING = 1; 1181 1182 select ((select (STDOUT), $| = 1)[0]); 1183$tm = "\n" x $tm; 1184$= -= $bm + 1; # count one for the trailing "----" 1185my $lastmin = 0; 1186 1187my @E; 1188 1189sub wryte 1190{ 1191 $lastmin = $-; 1192 write; 1193 } # wryte; 1194 1195sub footer 1196{ 1197 $% == 1 and return ""; 1198 1199 $lastmin < $= and print "\n" x $lastmin; 1200 print "\n" x $bm, "----\n", $ps; 1201 $lastmin = $-; 1202 ""; 1203 } # footer 1204 1205# Yes, this is sick ;-) 1206format TOP = 1207@* ~ 1208@{[footer]} 1209@* ~ 1210$tm 1211. 1212 1213format ENTRY = 1214@ @<<<<~~ 1215@{(shift @E)||["",""]} 1216. 1217 1218format EOR = 1219- ----- 1220. 1221 1222sub has_format ($) 1223{ 1224 my $fmt = shift; 1225 exists $::{$fmt} or return 0; 1226 $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; 1227 open my $null, "> /dev/null" or die; 1228 my $fh = select $null; 1229 local $~ = $fmt; 1230 eval "write"; 1231 select $fh; 1232 $@?0:1; 1233 } # has_format 1234 1235$^ = has_format ("TOP") ? "TOP" : "EMPTY"; 1236has_format ("ENTRY") or die "No format defined for ENTRY"; 1237foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], 1238 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { 1239 @E = @$e; 1240 local $~ = "ENTRY"; 1241 wryte; 1242 has_format ("EOR") or next; 1243 local $~ = "EOR"; 1244 wryte; 1245 } 1246if (has_format ("EOF")) { 1247 local $~ = "EOF"; 1248 wryte; 1249 } 1250 1251close STDOUT; 1252 1253# That was test 48. 1254 1255__END__ 1256 1257 1 Test1 1258 2 Test2 1259 3 Test3 1260 1261 1262 ---- 1263 1264 4 Test4 1265 5 Test5 1266 6 Test6 1267 1268 1269 ---- 1270 1271 7 Test7 1272 - ----- 1273 1274 1275 1276 ---- 1277 1278 1 1tseT 1279 2 2tseT 1280 3 3tseT 1281 1282 1283 ---- 1284 1285 4 4tseT 1286 5 5tseT 1287 - ----- 1288