t/op/write.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;     # Amazed that this hackery can be made strict ...
  10
  11 # read in a file
  12 sub 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
  23 sub swrite {
  24     my $format = shift;
  25     local $^A = ""; # don't litter, use a local bin
  26     formline( $format, @_ );
  27     return $^A;
  28 }
  29
  30 my @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
  54 my $num_tests = 0;
  55 for my $tref ( @NumTests ){
  56     $num_tests += (@$tref - 1)/2;
  57 }
  58 #---------------------------------------------------------
  59
  60 # number of tests in section 1
  61 my $bas_tests = 20;
  62
  63 # number of tests in section 3
  64 my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3;
  65
  66 # number of tests in section 4
  67 my $hmb_tests = 35;
  68
  69 my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;
  70
  71 plan $tests;
  72
  73 ############
  74 ## Section 1
  75 ############
  76
  77 use vars qw($fox $multiline $foo $good);
  78
  79 format OUT =
  80 the quick brown @<<
  81 $fox
  82 jumped
  83 @*
  84 $multiline
  85 ^<<<<<<<<<
  86 $foo
  87 ^<<<<<<<<<
  88 $foo
  89 ^<<<<<<...
  90 $foo
  91 now @<<the@>>>> for all@|||||men to come @<<<<
  92 {
  93     'i' . 's', "time\n", $good, 'to'
  94 }
  95 .
  96
  97 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
  98 END { 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';
 104 write(OUT);
 105 close OUT or die "Could not close: $!";
 106
 107 my $right =
 108 "the quick brown fox
 109 jumped
 110 forescore
 111 and
 112 seven years
 113 when in
 114 the course
 115 of huma...
 116 now is the time for all good men to come to\n";
 117
 118 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 119
 120 $fox = 'wolfishness';
 121 my $fox = 'foxiness';           # Test a lexical variable.
 122
 123 format OUT2 =
 124 the quick brown @<<
 125 $fox
 126 jumped
 127 @*
 128 $multiline
 129 ^<<<<<<<<< ~~
 130 $foo
 131 now @<<the@>>>> for all@|||||men to come @<<<<
 132 'i' . 's', "time\n", $good, 'to'
 133 .
 134
 135 open 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';
 140 write(OUT2);
 141 close OUT2 or die "Could not close: $!";
 142
 143 $right =
 144 "the quick brown fox
 145 jumped
 146 forescore
 147 and
 148 seven years
 149 when in
 150 the course
 151 of human
 152 events it
 153 becomes
 154 necessary
 155 now is the time for all good men to come to\n";
 156
 157 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 158
 159 eval <<'EOFORMAT';
 160 format OUT2 =
 161 the brown quick @<<
 162 $fox
 163 jumped
 164 @*
 165 $multiline
 166 and
 167 ^<<<<<<<<< ~~
 168 $foo
 169 now @<<the@>>>> for all@|||||men to come @<<<<
 170 'i' . 's', "time\n", $good, 'to'
 171 .
 172 EOFORMAT
 173
 174 open(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';
 180 write(OUT2);
 181 close OUT2 or die "Could not close: $!";
 182
 183 $right =
 184 "the brown quick fox
 185 jumped
 186 forescore
 187 and
 188 seven years
 189 and
 190 when in
 191 the course
 192 of human
 193 events it
 194 becomes
 195 necessary
 196 now is the time for all good men to come to\n";
 197
 198 is 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
 214 EOT
 215
 216 my $was1 = my $was2 = '';
 217 use vars '$format2';
 218 for (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 }
 230 is $was1, $right;
 231 is $was2, $right;
 232
 233 $^A = '';
 234
 235 # more test
 236
 237 format OUT3 =
 238 ^<<<<<<...
 239 $foo
 240 .
 241
 242 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 243
 244 $foo = 'fit          ';
 245 write(OUT3);
 246 close OUT3 or die "Could not close: $!";
 247
 248 $right =
 249 "fit\n";
 250
 251 is 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
 271 my %e = ( a => 1 );
 272 format OUT4 =
 273 @<<<<<<
 274 "$e{a}"
 275 .
 276 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
 277 write (OUT4);
 278 close  OUT4 or die "Could not close: $!";
 279 is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp";
 280
 281 eval <<'EOFORMAT';
 282 format OUT10 =
 283 @####.## @0###.##
 284 $test1, $test1
 285 .
 286 EOFORMAT
 287
 288 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 289
 290 use vars '$test1';
 291 $test1 = 12.95;
 292 write(OUT10);
 293 close OUT10 or die "Could not close: $!";
 294
 295 $right = "   12.95 00012.95\n";
 296 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 297
 298 eval <<'EOFORMAT';
 299 format OUT11 =
 300 @0###.##
 301 $test1
 302 @ 0#
 303 $test1
 304 @0 #
 305 $test1
 306 .
 307 EOFORMAT
 308
 309 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 310
 311 $test1 = 12.95;
 312 write(OUT11);
 313 close OUT11 or die "Could not close: $!";
 314
 315 $right =
 316 "00012.95
 317 1 0#
 318 10 #\n";
 319 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 320
 321 {
 322     my $test = curr_test();
 323     my $el;
 324     format OUT12 =
 325 ok ^<<<<<<<<<<<<<<~~ # 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 =
 347 ok ^<<<<<<<<< ~~
 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;
 394 this_is_block_1   this_is_block_2
 395 this_is_block_3   this_is_block_4
 396 EOD
 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 =
 404 Here 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;
 413 Here we go: $txt That's all, folks!
 414 EOD
 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 @######## ~~
 423 10
 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;
 443 gaga\0
 444 gaga\0
 445 EOD
 446 }
 447
 448 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
 449     my %h = ( xkey => 'xval', ykey => 'yval' );
 450     format OUT20 =
 451 @>>>> @<<<< ~~
 452 each %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
 480 curr_test($bas_tests + 1);
 481
 482 for 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           $format = "1^*2 3${format}4";
 546           foreach my $class ('', 'Count') {
 547             my $name = qq{swrite("$format", "$first", "$second") class="$class"};
 548             $name =~ s/\n/\\n/g;
 549             $name =~ s{(.)}{
 550                         ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
 551                     }ge;
 552
 553             $first =~ /(.+)/ or die $first;
 554             my $expect = "1${1}2";
 555             $second =~ $re or die $second;
 556             $expect .= " 3${1}4";
 557
 558             if ($class) {
 559               my $copy1 = $first;
 560               my $copy2;
 561               tie $copy2, $class, $second;
 562               is swrite("$format", $copy1, $copy2), $expect, $name;
 563               my $obj = tied $copy2;
 564               is $obj->[1], 1, 'value read exactly once';
 565             } else {
 566               my ($copy1, $copy2) = ($first, $second);
 567               is swrite("$format", $copy1, $copy2), $expect, $name;
 568             }
 569           }
 570         }
 571       }
 572     }
 573   }
 574 }
 575
 576 {
 577   # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
 578   # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
 579   # be doing something similarly out of bounds on everything from 5.000
 580   my $ref = [];
 581   is swrite('>^*<', $ref), ">$ref<";
 582   is swrite('>@*<', $ref), ">$ref<";
 583 }
 584
 585 format EMPTY =
 586 .
 587
 588 my $test = curr_test();
 589
 590 format Comment =
 591 ok @<<<<<
 592 $test
 593 .
 594
 595
 596 # RT #8698 format bug with undefined _TOP
 597
 598 open STDOUT_DUP, ">&STDOUT";
 599 my $oldfh = select STDOUT_DUP;
 600 $= = 10;
 601 {
 602   local $~ = "Comment";
 603   write;
 604   curr_test($test + 1);
 605   is $-, 9;
 606   is $^, "STDOUT_DUP_TOP";
 607 }
 608 select $oldfh;
 609 close STDOUT_DUP;
 610
 611 *CmT =  *{$::{Comment}}{FORMAT};
 612 ok  defined *{$::{CmT}}{FORMAT}, "glob assign";
 613
 614
 615 # RT #91032: Check that "non-real" strings like tie and overload work,
 616 # especially that they re-compile the pattern on each FETCH, and that
 617 # they don't overrun the buffer
 618
 619
 620 {
 621     package RT91032;
 622
 623     sub TIESCALAR { bless [] }
 624     my $i = 0;
 625     sub FETCH { $i++; "A$i @> Z\n" }
 626
 627     use overload '""' => \&FETCH;
 628
 629     tie my $f, 'RT91032';
 630
 631     formline $f, "a";
 632     formline $f, "bc";
 633     ::is $^A, "A1  a Z\nA2 bc Z\n", "RT 91032: tied";
 634     $^A = '';
 635
 636     my $g = bless []; # has overloaded stringify
 637     formline $g, "de";
 638     formline $g, "f";
 639     ::is $^A, "A3 de Z\nA4  f Z\n", "RT 91032: overloaded";
 640     $^A = '';
 641
 642     my $h = [];
 643     formline $h, "junk1";
 644     formline $h, "junk2";
 645     ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref";
 646     ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok";
 647     ::is $^A, "$h$h","RT 91032: stringified array";
 648     $^A = '';
 649
 650     # used to overwrite the ~~ in the *original SV with spaces. Naughty!
 651
 652     my $orig = my $format = "^<<<<< ~~\n";
 653     my $abc = "abc";
 654     formline $format, $abc;
 655     $^A ='';
 656     ::is $format, $orig, "RT91032: don't overwrite orig format string";
 657
 658     # check that ~ and ~~ are displayed correctly as whitespace,
 659     # under the influence of various different types of border
 660
 661     for my $n (1,2) {
 662         for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
 663             for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
 664                 my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
 665                 my $sfmt = ($fmt =~ s/~/ /gr);
 666                 my ($a, $bc, $stop);
 667                 ($a, $bc, $stop) = ('a', 'bc', 's');
 668                 # $stop is to stop '~~' deleting the whole line
 669                 formline $sfmt, $stop, $a, $bc;
 670                 my $exp = $^A;
 671                 $^A = '';
 672                 ($a, $bc, $stop) = ('a', 'bc', 's');
 673                 formline $fmt, $stop, $a, $bc;
 674                 my $got = $^A;
 675                 $^A = '';
 676                 $fmt =~ s/\n/\\n/;
 677                 ::is($got, $exp, "chop munging: [$fmt]");
 678             }
 679         }
 680     }
 681 }
 682
 683 # check that '~  (delete current line if empty) works when
 684 # the target gets upgraded to uft8 (and re-allocated) midstream.
 685
 686 {
 687     my $format = "\x{100}@~\n"; # format is utf8
 688     # this target is not utf8, but will expand (and get reallocated)
 689     # when upgraded to utf8.
 690     my $orig = "\x80\x81\x82";
 691     local $^A = $orig;
 692     my $empty = "";
 693     formline $format, $empty;
 694     is $^A , $orig, "~ and realloc";
 695
 696     # check similarly that trailing blank removal works ok
 697
 698     $format = "@<\n\x{100}"; # format is utf8
 699     chop $format;
 700     $orig = "   ";
 701     $^A = $orig;
 702     formline $format, "  ";
 703     is $^A, "$orig\n", "end-of-line blanks and realloc";
 704
 705     # and check this doesn't overflow the buffer
 706
 707     local $^A = '';
 708     $format = "@* @####\n";
 709     $orig = "x" x 100 . "\n";
 710     formline $format, $orig, 12345;
 711     is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
 712
 713     # make sure it can cope with formats > 64k
 714
 715     $format = 'x' x 65537;
 716     $^A = '';
 717     formline $format;
 718     # don't use 'is' here, as the diag output will be too long!
 719     ok $^A eq $format, ">64K";
 720 }
 721
 722
 723 SKIP: {
 724     skip_if_miniperl('miniperl does not support scalario');
 725     my $buf = "";
 726     open my $fh, ">", \$buf;
 727     my $old_fh = select $fh;
 728     local $~ = "CmT";
 729     write;
 730     select $old_fh;
 731     close $fh;
 732     is $buf, "ok $test\n", "write to duplicated format";
 733 }
 734
 735 format caret_A_test_TOP =
 736 T
 737 .
 738
 739 format caret_A_test =
 740 L1
 741 L2
 742 L3
 743 L4
 744 .
 745
 746 SKIP: {
 747     skip_if_miniperl('miniperl does not support scalario');
 748     my $buf = "";
 749     open my $fh, ">", \$buf;
 750     my $old_fh = select $fh;
 751     local $^ = "caret_A_test_TOP";
 752     local $~ = "caret_A_test";
 753     local $= = 3;
 754     local $^A = "A1\nA2\nA3\nA4\n";
 755     write;
 756     select $old_fh;
 757     close $fh;
 758     is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n",
 759                     "assign to ^A sets FmLINES";
 760 }
 761
 762 fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
 763 #!./perl
 764
 765 use strict;
 766 use warnings; # crashes!
 767
 768 format =
 769 .
 770
 771 write;
 772
 773 format =
 774 .
 775
 776 write;
 777 EOP
 778
 779 fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments');
 780 use strict;
 781 use warnings;
 782 my $zamm = ['crunch_eth'];
 783 formline $zamm;
 784 printf ">%s<\n", ref $zamm;
 785 print "$zamm->[0]\n";
 786 EOP
 787
 788 #############################
 789 ## Section 4
 790 ## Add new tests *above* here
 791 #############################
 792
 793 # scary format testing from H.Merijn Brand
 794
 795 # Just a complete test for format, including top-, left- and bottom marging
 796 # and format detection through glob entries
 797
 798 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
 799     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
 800   $test = curr_test();
 801  SKIP: {
 802       skip "'|-' and '-|' not supported", $tests - $test + 1;
 803   }
 804   exit(0);
 805 }
 806
 807
 808 $^  = "STDOUT_TOP";
 809 $=  =  7;               # Page length
 810 $-  =  0;               # Lines left
 811 my $ps = $^L; $^L = ""; # Catch the page separator
 812 my $tm =  1;            # Top margin (empty lines before first output)
 813 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 814 my $lm =  4;            # Left margin (indent in spaces)
 815
 816 # -----------------------------------------------------------------------
 817 #
 818 # execute the rest of the script in a child process. The parent reads the
 819 # output from the child and compares it with <DATA>.
 820
 821 my @data = <DATA>;
 822
 823 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
 824
 825 my $opened = open FROM_CHILD, "-|";
 826 unless (defined $opened) {
 827     fail "open gave $!";
 828     exit 0;
 829 }
 830
 831 if ($opened) {
 832     # in parent here
 833
 834     pass 'open';
 835     my $s = " " x $lm;
 836     while (<FROM_CHILD>) {
 837         unless (@data) {
 838             fail 'too much output';
 839             exit;
 840         }
 841         s/^/$s/;
 842         my $exp = shift @data;
 843         is $_, $exp;
 844     }
 845     close FROM_CHILD;
 846     is "@data", "", "correct length of output";
 847     exit;
 848 }
 849
 850 # in child here
 851 $::NO_ENDING = 1;
 852
 853     select ((select (STDOUT), $| = 1)[0]);
 854 $tm = "\n" x $tm;
 855 $= -= $bm + 1; # count one for the trailing "----"
 856 my $lastmin = 0;
 857
 858 my @E;
 859
 860 sub wryte
 861 {
 862     $lastmin = $-;
 863     write;
 864     } # wryte;
 865
 866 sub footer
 867 {
 868     $% == 1 and return "";
 869
 870     $lastmin < $= and print "\n" x $lastmin;
 871     print "\n" x $bm, "----\n", $ps;
 872     $lastmin = $-;
 873     "";
 874     } # footer
 875
 876 # Yes, this is sick ;-)
 877 format TOP =
 878 @* ~
 879 @{[footer]}
 880 @* ~
 881 $tm
 882 .
 883
 884 format ENTRY =
 885 @ @<<<<~~
 886 @{(shift @E)||["",""]}
 887 .
 888
 889 format EOR =
 890 - -----
 891 .
 892
 893 sub has_format ($)
 894 {
 895     my $fmt = shift;
 896     exists $::{$fmt} or return 0;
 897     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 898     open my $null, "> /dev/null" or die;
 899     my $fh = select $null;
 900     local $~ = $fmt;
 901     eval "write";
 902     select $fh;
 903     $@?0:1;
 904     } # has_format
 905
 906 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 907 has_format ("ENTRY") or die "No format defined for ENTRY";
 908 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 909                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 910     @E = @$e;
 911     local $~ = "ENTRY";
 912     wryte;
 913     has_format ("EOR") or next;
 914     local $~ = "EOR";
 915     wryte;
 916     }
 917 if (has_format ("EOF")) {
 918     local $~ = "EOF";
 919     wryte;
 920     }
 921
 922 close STDOUT;
 923
 924 # That was test 48.
 925
 926 __END__
 927
 928     1 Test1
 929     2 Test2
 930     3 Test3
 931
 932
 933     ----
 934     \f
 935     4 Test4
 936     5 Test5
 937     6 Test6
 938
 939
 940     ----
 941     \f
 942     7 Test7
 943     - -----
 944
 945
 946
 947     ----
 948     \f
 949     1 1tseT
 950     2 2tseT
 951     3 3tseT
 952
 953
 954     ----
 955     \f
 956     4 4tseT
 957     5 5tseT
 958     - -----