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 use Tie::Scalar;
  11
  12 # read in a file
  13 sub cat {
  14     my $file = shift;
  15     local $/;
  16     open my $fh, $file or die "can't open '$file': $!";
  17     my $data = <$fh>;
  18     close $fh;
  19     $data;
  20 }
  21
  22 # read in a utf-8 file
  23 #
  24 sub cat_utf8 {
  25     my $file = shift;
  26     local $/;
  27     open my $fh, '<', $file or die "can't open '$file': $!";
  28     binmode $fh, ':utf8';
  29     my $data = <$fh> // die "Can't read from '$file': $!";
  30     close $fh or die "error closing '$file': $!";
  31     $data;
  32 }
  33
  34 # write a format to a utf8 file, then read it back in and compare
  35
  36 sub is_format_utf8 {
  37     my ($glob, $want, $desc) = @_;
  38     local $::Level = $::Level + 1;
  39     my $file = 'Op_write.tmp';
  40     open $glob, '>:utf8', $file or die "Can't create '$file': $!";
  41     write $glob;
  42     close $glob or die "Could not close '$file': $!";
  43     is(cat_utf8($file), $want, $desc);
  44 }
  45
  46 sub like_format_utf8 {
  47     my ($glob, $want, $desc) = @_;
  48     local $::Level = $::Level + 1;
  49     my $file = 'Op_write.tmp';
  50     open $glob, '>:utf8', $file or die "Can't create '$file': $!";
  51     write $glob;
  52     close $glob or die "Could not close '$file': $!";
  53     like(cat_utf8($file), $want, $desc);
  54 }
  55
  56
  57
  58 #-- testing numeric fields in all variants (WL)
  59
  60 sub swrite {
  61     my $format = shift;
  62     local $^A = ""; # don't litter, use a local bin
  63     formline( $format, @_ );
  64     return $^A;
  65 }
  66
  67 my @NumTests = (
  68     # [ format, value1, expected1, value2, expected2, .... ]
  69     [ '@###',           0,   '   0',         1, '   1',     9999.6, '####',
  70                 9999.4999,   '9999',    -999.6, '####',     1e+100, '####' ],
  71
  72     [ '@0##',           0,   '0000',         1, '0001',     9999.6, '####',
  73                 -999.4999,   '-999',    -999.6, '####',     1e+100, '####' ],
  74
  75     [ '^###',           0,   '   0',     undef, '    ' ],
  76
  77     [ '^0##',           0,   '0000',     undef, '    ' ],
  78
  79     [ '@###.',          0,  '   0.',         1, '   1.',    9999.6, '#####',
  80                 9999.4999,  '9999.',    -999.6, '#####' ],
  81
  82     [ '@##.##',         0, '  0.00',         1, '  1.00',  999.996, '######',
  83                 999.99499, '999.99',      -100, '######' ],
  84
  85     [ '@0#.##',         0, '000.00',         1, '001.00',       10, '010.00',
  86                   -0.0001, qr/^[\-0]00\.00$/ ],
  87
  88 );
  89
  90
  91 my $num_tests = 0;
  92 for my $tref ( @NumTests ){
  93     $num_tests += (@$tref - 1)/2;
  94 }
  95 #---------------------------------------------------------
  96
  97 # number of tests in section 1
  98 my $bas_tests = 21;
  99
 100 # number of tests in section 3
 101 my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11;
 102
 103 # number of tests in section 4
 104 my $hmb_tests = 37;
 105
 106 my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;
 107
 108 plan $tests;
 109
 110 ############
 111 ## Section 1
 112 ############
 113
 114 use vars qw($fox $multiline $foo $good);
 115
 116 format OUT =
 117 the quick brown @<<
 118 $fox
 119 jumped
 120 @*
 121 $multiline
 122 ^<<<<<<<<<
 123 $foo
 124 ^<<<<<<<<<
 125 $foo
 126 ^<<<<<<...
 127 $foo
 128 now @<<the@>>>> for all@|||||men to come @<<<<
 129 {
 130     'i' . 's', "time\n", $good, 'to'
 131 }
 132 .
 133
 134 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 135 END { unlink_all 'Op_write.tmp' }
 136
 137 $fox = 'foxiness';
 138 $good = 'good';
 139 $multiline = "forescore\nand\nseven years\n";
 140 $foo = 'when in the course of human events it becomes necessary';
 141 write(OUT);
 142 close OUT or die "Could not close: $!";
 143
 144 my $right =
 145 "the quick brown fox
 146 jumped
 147 forescore
 148 and
 149 seven years
 150 when in
 151 the course
 152 of huma...
 153 now is the time for all good men to come to\n";
 154
 155 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 156
 157 $fox = 'wolfishness';
 158 my $fox = 'foxiness';           # Test a lexical variable.
 159
 160 format OUT2 =
 161 the quick brown @<<
 162 $fox
 163 jumped
 164 @*
 165 $multiline
 166 ^<<<<<<<<< ~~
 167 $foo
 168 now @<<the@>>>> for all@|||||men to come @<<<<
 169 'i' . 's', "time\n", $good, 'to'
 170 .
 171
 172 open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
 173
 174 $good = 'good';
 175 $multiline = "forescore\nand\nseven years\n";
 176 $foo = 'when in the course of human events it becomes necessary';
 177 write(OUT2);
 178 close OUT2 or die "Could not close: $!";
 179
 180 $right =
 181 "the quick brown fox
 182 jumped
 183 forescore
 184 and
 185 seven years
 186 when in
 187 the course
 188 of human
 189 events it
 190 becomes
 191 necessary
 192 now is the time for all good men to come to\n";
 193
 194 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 195
 196 eval <<'EOFORMAT';
 197 format OUT2 =
 198 the brown quick @<<
 199 $fox
 200 jumped
 201 @*
 202 $multiline
 203 and
 204 ^<<<<<<<<< ~~
 205 $foo
 206 now @<<the@>>>> for all@|||||men to come @<<<<
 207 'i' . 's', "time\n", $good, 'to'
 208 .
 209 EOFORMAT
 210
 211 open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 212
 213 $fox = 'foxiness';
 214 $good = 'good';
 215 $multiline = "forescore\nand\nseven years\n";
 216 $foo = 'when in the course of human events it becomes necessary';
 217 write(OUT2);
 218 close OUT2 or die "Could not close: $!";
 219
 220 $right =
 221 "the brown quick fox
 222 jumped
 223 forescore
 224 and
 225 seven years
 226 and
 227 when in
 228 the course
 229 of human
 230 events it
 231 becomes
 232 necessary
 233 now is the time for all good men to come to\n";
 234
 235 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 236
 237 # formline tests
 238
 239 $right = <<EOT;
 240 @ a
 241 @> ab
 242 @>> abc
 243 @>>>  abc
 244 @>>>>   abc
 245 @>>>>>    abc
 246 @>>>>>>     abc
 247 @>>>>>>>      abc
 248 @>>>>>>>>       abc
 249 @>>>>>>>>>        abc
 250 @>>>>>>>>>>         abc
 251 EOT
 252
 253 my $was1 = my $was2 = '';
 254 use vars '$format2';
 255 for (0..10) {
 256   # lexical picture
 257   $^A = '';
 258   my $format1 = '@' . '>' x $_;
 259   formline $format1, 'abc';
 260   $was1 .= "$format1 $^A\n";
 261   # global
 262   $^A = '';
 263   local $format2 = '@' . '>' x $_;
 264   formline $format2, 'abc';
 265   $was2 .= "$format2 $^A\n";
 266 }
 267 is $was1, $right;
 268 is $was2, $right;
 269
 270 $^A = '';
 271
 272 # more test
 273
 274 format OUT3 =
 275 ^<<<<<<...
 276 $foo
 277 .
 278
 279 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 280
 281 $foo = 'fit          ';
 282 write(OUT3);
 283 close OUT3 or die "Could not close: $!";
 284
 285 $right =
 286 "fit\n";
 287
 288 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 289
 290
 291 # test lexicals and globals
 292 {
 293     my $test = curr_test();
 294     my $this = "ok";
 295     our $that = $test;
 296     format LEX =
 297 @<<@|
 298 $this,$that
 299 .
 300     open(LEX, ">&STDOUT") or die;
 301     write LEX;
 302     $that = ++$test;
 303     write LEX;
 304     close LEX or die "Could not close: $!";
 305     curr_test($test + 1);
 306 }
 307 # LEX_INTERPNORMAL test
 308 my %e = ( a => 1 );
 309 format OUT4 =
 310 @<<<<<<
 311 "$e{a}"
 312 .
 313 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
 314 write (OUT4);
 315 close  OUT4 or die "Could not close: $!";
 316 is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp";
 317
 318 # More LEX_INTERPNORMAL
 319 format OUT4a=
 320 @<<<<<<<<<<<<<<<
 321 "${; use
 322      strict; \'Nasdaq dropping like flies'}"
 323 .
 324 open   OUT4a, ">Op_write.tmp" or die "Can't create Op_write.tmp";
 325 write (OUT4a);
 326 close  OUT4a or die "Could not close: $!";
 327 is cat('Op_write.tmp'), "Nasdaq dropping\n", 'skipspace inside "${...}"'
 328     and unlink_all "Op_write.tmp";
 329
 330 eval <<'EOFORMAT';
 331 format OUT10 =
 332 @####.## @0###.##
 333 $test1, $test1
 334 .
 335 EOFORMAT
 336
 337 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 338
 339 use vars '$test1';
 340 $test1 = 12.95;
 341 write(OUT10);
 342 close OUT10 or die "Could not close: $!";
 343
 344 $right = "   12.95 00012.95\n";
 345 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 346
 347 eval <<'EOFORMAT';
 348 format OUT11 =
 349 @0###.##
 350 $test1
 351 @ 0#
 352 $test1
 353 @0 #
 354 $test1
 355 .
 356 EOFORMAT
 357
 358 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 359
 360 $test1 = 12.95;
 361 write(OUT11);
 362 close OUT11 or die "Could not close: $!";
 363
 364 $right =
 365 "00012.95
 366 1 0#
 367 10 #\n";
 368 is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp';
 369
 370 {
 371     my $test = curr_test();
 372     my $el;
 373     format OUT12 =
 374 ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
 375 $el
 376 .
 377     my %hash = ($test => 3);
 378     open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 379
 380     for $el (keys %hash) {
 381         write(OUT12);
 382     }
 383     close OUT12 or die "Could not close: $!";
 384     print cat('Op_write.tmp');
 385     curr_test($test + 1);
 386 }
 387
 388 {
 389     my $test = curr_test();
 390     # Bug report and testcase by Alexey Tourbin
 391     my $v;
 392     tie $v, 'Tie::StdScalar';
 393     $v = $test;
 394     format OUT13 =
 395 ok ^<<<<<<<<< ~~
 396 $v
 397 .
 398     open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 399     write(OUT13);
 400     close OUT13 or die "Could not close: $!";
 401     print cat('Op_write.tmp');
 402     curr_test($test + 1);
 403 }
 404
 405 {   # test 14
 406     # Bug #24774 format without trailing \n failed assertion, but this
 407     # must fail since we have a trailing ; in the eval'ed string (WL)
 408     my @v = ('k');
 409     eval "format OUT14 = \n@\n\@v";
 410     like $@, qr/Format not terminated/;
 411 }
 412
 413 {   # test 15
 414     # text lost in ^<<< field with \r in value (WL)
 415     my $txt = "line 1\rline 2";
 416     format OUT15 =
 417 ^<<<<<<<<<<<<<<<<<<
 418 $txt
 419 ^<<<<<<<<<<<<<<<<<<
 420 $txt
 421 .
 422     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 423     write(OUT15);
 424     close OUT15 or die "Could not close: $!";
 425     my $res = cat('Op_write.tmp');
 426     is $res, "line 1\nline 2\n";
 427 }
 428
 429 {   # test 16: multiple use of a variable in same line with ^<
 430     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
 431     format OUT16 =
 432 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
 433 $txt,             $txt
 434 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
 435 $txt,             $txt
 436 .
 437     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 438     write(OUT16);
 439     close OUT16 or die "Could not close: $!";
 440     my $res = cat('Op_write.tmp');
 441     is $res, <<EOD;
 442 this_is_block_1   this_is_block_2
 443 this_is_block_3   this_is_block_4
 444 EOD
 445 }
 446
 447 {   # test 17: @* "should be on a line of its own", but it should work
 448     # cleanly with literals before and after. (WL)
 449
 450     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
 451     format OUT17 =
 452 Here we go: @* That's all, folks!
 453             $txt
 454 .
 455     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 456     write(OUT17);
 457     close OUT17 or die "Could not close: $!";
 458     my $res = cat('Op_write.tmp');
 459     chomp( $txt );
 460     my $exp = <<EOD;
 461 Here we go: $txt That's all, folks!
 462 EOD
 463     is $res, $exp;
 464 }
 465
 466 {   # test 18: @# and ~~ would cause runaway format, but we now
 467     # catch this while compiling (WL)
 468
 469     format OUT18 =
 470 @######## ~~
 471 10
 472 .
 473     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 474     eval { write(OUT18); };
 475     like $@,  qr/Repeated format line will never terminate/;
 476     close OUT18 or die "Could not close: $!";
 477 }
 478
 479 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
 480     my $v = 'gaga';
 481     eval "format OUT19 = \n" .
 482          '@<<<' . "\0\n" .
 483          '$v' .   "\n" .
 484          '@<<<' . "\0\n" .
 485          '$v' . "\n.\n";
 486     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 487     write(OUT19);
 488     close OUT19 or die "Could not close: $!";
 489     my $res = cat('Op_write.tmp');
 490     is $res, <<EOD;
 491 gaga\0
 492 gaga\0
 493 EOD
 494 }
 495
 496 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
 497     my %h = ( xkey => 'xval', ykey => 'yval' );
 498     format OUT20 =
 499 @>>>> @<<<< ~~
 500 each %h
 501 @>>>> @<<<<
 502 $h{xkey}, $h{ykey}
 503 @>>>> @<<<<
 504 { $h{xkey}, $h{ykey}
 505 }
 506 }
 507 .
 508     my $exp = '';
 509     while( my( $k, $v ) = each( %h ) ){
 510         $exp .= sprintf( "%5s %s\n", $k, $v );
 511     }
 512     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
 513     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
 514     $exp .= "}\n";
 515     open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 516     write(OUT20);
 517     close OUT20 or die "Could not close: $!";
 518     my $res = cat('Op_write.tmp');
 519     is $res, $exp;
 520 }
 521
 522
 523 #####################
 524 ## Section 2
 525 ## numeric formatting
 526 #####################
 527
 528 curr_test($bas_tests + 1);
 529
 530 for my $tref ( @NumTests ){
 531     my $writefmt = shift( @$tref );
 532     while (@$tref) {
 533         my $val      = shift @$tref;
 534         my $expected = shift @$tref;
 535         my $writeres = swrite( $writefmt, $val );
 536         if (ref $expected) {
 537             like $writeres, $expected, $writefmt;
 538         } else {
 539             is $writeres, $expected, $writefmt;
 540         }
 541     }
 542 }
 543
 544
 545 #####################################
 546 ## Section 3
 547 ## Easiest to add new tests just here
 548 #####################################
 549
 550 # DAPM. Exercise a couple of error codepaths
 551
 552 {
 553     local $~ = '';
 554     eval { write };
 555     like $@, qr/Undefined format ""/, 'format with 0-length name';
 556
 557     $~ = "\0foo";
 558     eval { write };
 559     like $@, qr/Undefined format "\0foo"/,
 560         'no such format beginning with null';
 561
 562     $~ = "NOSUCHFORMAT";
 563     eval { write };
 564     like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format';
 565 }
 566
 567 select +(select(OUT21), do {
 568     open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 569
 570     format OUT21 =
 571 @<<
 572 $_
 573 .
 574
 575     local $^ = '';
 576     local $= = 1;
 577     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
 578     like $@, qr/Undefined top format ""/, 'top format with 0-length name';
 579
 580     $^ = "\0foo";
 581     # For some reason, we have to do this twice to get the error again.
 582     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
 583     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
 584     like $@, qr/Undefined top format "\0foo"/,
 585         'no such top format beginning with null';
 586
 587     $^ = "NOSUCHFORMAT";
 588     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
 589     $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
 590     like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format';
 591
 592     # reset things;
 593     eval { write(OUT21) };
 594     undef $^A;
 595
 596     close OUT21 or die "Could not close: $!";
 597 })[0];
 598
 599
 600
 601 # [perl #119847],  [perl #119849], [perl #119851]
 602 # Non-real vars like tied, overloaded and refs could, when stringified,
 603 # fail to be processed properly, causing infinite loops on ~~, utf8
 604 # warnings etc, ad nauseum.
 605
 606
 607 my $u22a = "N" x 8;
 608
 609 format OUT22a =
 610 '^<<<<<<<<'~~
 611 $u22a
 612 .
 613
 614 is_format_utf8(\*OUT22a,
 615                "'NNNNNNNN '\n");
 616
 617
 618 my $u22b = "N" x 8;
 619 utf8::upgrade($u22b);
 620
 621 format OUT22b =
 622 '^<<<<<<<<'~~
 623 $u22b
 624 .
 625
 626 is_format_utf8(\*OUT22b,
 627                "'NNNNNNNN '\n");
 628
 629 my $u22c = "\x{FF}" x 8;
 630
 631 format OUT22c =
 632 '^<<<<<<<<'~~
 633 $u22c
 634 .
 635
 636 is_format_utf8(\*OUT22c,
 637                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
 638
 639 my $u22d = "\x{FF}" x 8;
 640 utf8::upgrade($u22d);
 641
 642 format OUT22d =
 643 '^<<<<<<<<'~~
 644 $u22d
 645 .
 646
 647 is_format_utf8(\*OUT22d,
 648                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
 649
 650 my $u22e = "\x{100}" x 8;
 651
 652 format OUT22e =
 653 '^<<<<<<<<'~~
 654 $u22e
 655 .
 656
 657 is_format_utf8(\*OUT22e,
 658                "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n");
 659
 660
 661 my $u22f = "N" x 8;
 662
 663 format OUT22f =
 664 '^<'~~
 665 $u22f
 666 .
 667
 668 is_format_utf8(\*OUT22f,
 669                "'NN'\n"x4);
 670
 671
 672 my $u22g = "N" x 8;
 673 utf8::upgrade($u22g);
 674
 675 format OUT22g =
 676 '^<'~~
 677 $u22g
 678 .
 679
 680 is_format_utf8(\*OUT22g,
 681                "'NN'\n"x4);
 682
 683 my $u22h = "\x{FF}" x 8;
 684
 685 format OUT22h =
 686 '^<'~~
 687 $u22h
 688 .
 689
 690 is_format_utf8(\*OUT22h,
 691                "'\x{FF}\x{FF}'\n"x4);
 692
 693 my $u22i = "\x{FF}" x 8;
 694 utf8::upgrade($u22i);
 695
 696 format OUT22i =
 697 '^<'~~
 698 $u22i
 699 .
 700
 701 is_format_utf8(\*OUT22i,
 702                "'\x{FF}\x{FF}'\n"x4);
 703
 704 my $u22j = "\x{100}" x 8;
 705
 706 format OUT22j =
 707 '^<'~~
 708 $u22j
 709 .
 710
 711 is_format_utf8(\*OUT22j,
 712                "'\x{100}\x{100}'\n"x4);
 713
 714
 715 tie my $u23a, 'Tie::StdScalar';
 716 $u23a = "N" x 8;
 717
 718 format OUT23a =
 719 '^<<<<<<<<'~~
 720 $u23a
 721 .
 722
 723 is_format_utf8(\*OUT23a,
 724                "'NNNNNNNN '\n");
 725
 726
 727 tie my $u23b, 'Tie::StdScalar';
 728 $u23b = "N" x 8;
 729 utf8::upgrade($u23b);
 730
 731 format OUT23b =
 732 '^<<<<<<<<'~~
 733 $u23b
 734 .
 735
 736 is_format_utf8(\*OUT23b,
 737                "'NNNNNNNN '\n");
 738
 739 tie my $u23c, 'Tie::StdScalar';
 740 $u23c = "\x{FF}" x 8;
 741
 742 format OUT23c =
 743 '^<<<<<<<<'~~
 744 $u23c
 745 .
 746
 747 is_format_utf8(\*OUT23c,
 748                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
 749
 750 tie my $u23d, 'Tie::StdScalar';
 751 my $temp = "\x{FF}" x 8;
 752 utf8::upgrade($temp);
 753 $u23d = $temp;
 754
 755 format OUT23d =
 756 '^<<<<<<<<'~~
 757 $u23d
 758 .
 759
 760 is_format_utf8(\*OUT23d,
 761                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
 762
 763 tie my $u23e, 'Tie::StdScalar';
 764 $u23e = "\x{100}" x 8;
 765
 766 format OUT23e =
 767 '^<<<<<<<<'~~
 768 $u23e
 769 .
 770
 771 is_format_utf8(\*OUT23e,
 772                "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n");
 773
 774 tie my $u23f, 'Tie::StdScalar';
 775 $u23f = "N" x 8;
 776
 777 format OUT23f =
 778 '^<'~~
 779 $u23f
 780 .
 781
 782 is_format_utf8(\*OUT23f,
 783                "'NN'\n"x4);
 784
 785
 786 tie my $u23g, 'Tie::StdScalar';
 787 my $temp = "N" x 8;
 788 utf8::upgrade($temp);
 789 $u23g = $temp;
 790
 791 format OUT23g =
 792 '^<'~~
 793 $u23g
 794 .
 795
 796 is_format_utf8(\*OUT23g,
 797                "'NN'\n"x4);
 798
 799 tie my $u23h, 'Tie::StdScalar';
 800 $u23h = "\x{FF}" x 8;
 801
 802 format OUT23h =
 803 '^<'~~
 804 $u23h
 805 .
 806
 807 is_format_utf8(\*OUT23h,
 808                "'\x{FF}\x{FF}'\n"x4);
 809
 810 $temp = "\x{FF}" x 8;
 811 utf8::upgrade($temp);
 812 tie my $u23i, 'Tie::StdScalar';
 813 $u23i = $temp;
 814
 815 format OUT23i =
 816 '^<'~~
 817 $u23i
 818 .
 819
 820 is_format_utf8(\*OUT23i,
 821                "'\x{FF}\x{FF}'\n"x4);
 822
 823 tie my $u23j, 'Tie::StdScalar';
 824 $u23j = "\x{100}" x 8;
 825
 826 format OUT23j =
 827 '^<'~~
 828 $u23j
 829 .
 830
 831 is_format_utf8(\*OUT23j,
 832                "'\x{100}\x{100}'\n"x4);
 833
 834 {
 835     package UTF8Toggle;
 836
 837     sub TIESCALAR {
 838         my $class = shift;
 839         my $value = shift;
 840         my $state = shift||0;
 841         return bless [$value, $state], $class;
 842     }
 843
 844     sub FETCH {
 845         my $self = shift;
 846         $self->[1] = ! $self->[1];
 847         if ($self->[1]) {
 848            utf8::downgrade($self->[0]);
 849         } else {
 850            utf8::upgrade($self->[0]);
 851         }
 852         $self->[0];
 853     }
 854
 855    sub STORE {
 856        my $self = shift;
 857        $self->[0] = shift;
 858     }
 859 }
 860
 861 tie my $u24a, 'UTF8Toggle';
 862 $u24a = "N" x 8;
 863
 864 format OUT24a =
 865 '^<<<<<<<<'~~
 866 $u24a
 867 .
 868
 869 is_format_utf8(\*OUT24a,
 870                "'NNNNNNNN '\n");
 871
 872
 873 tie my $u24b, 'UTF8Toggle';
 874 $u24b = "N" x 8;
 875 utf8::upgrade($u24b);
 876
 877 format OUT24b =
 878 '^<<<<<<<<'~~
 879 $u24b
 880 .
 881
 882 is_format_utf8(\*OUT24b,
 883                "'NNNNNNNN '\n");
 884
 885 tie my $u24c, 'UTF8Toggle';
 886 $u24c = "\x{FF}" x 8;
 887
 888 format OUT24c =
 889 '^<<<<<<<<'~~
 890 $u24c
 891 .
 892
 893 is_format_utf8(\*OUT24c,
 894                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
 895
 896 tie my $u24d, 'UTF8Toggle', 1;
 897 $u24d = "\x{FF}" x 8;
 898
 899 format OUT24d =
 900 '^<<<<<<<<'~~
 901 $u24d
 902 .
 903
 904 is_format_utf8(\*OUT24d,
 905                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
 906
 907
 908
 909 tie my $u24f, 'UTF8Toggle';
 910 $u24f = "N" x 8;
 911
 912 format OUT24f =
 913 '^<'~~
 914 $u24f
 915 .
 916
 917 is_format_utf8(\*OUT24f,
 918                "'NN'\n"x4);
 919
 920
 921 tie my $u24g, 'UTF8Toggle';
 922 my $temp = "N" x 8;
 923 utf8::upgrade($temp);
 924 $u24g = $temp;
 925
 926 format OUT24g =
 927 '^<'~~
 928 $u24g
 929 .
 930
 931 is_format_utf8(\*OUT24g,
 932                "'NN'\n"x4);
 933
 934 tie my $u24h, 'UTF8Toggle';
 935 $u24h = "\x{FF}" x 8;
 936
 937 format OUT24h =
 938 '^<'~~
 939 $u24h
 940 .
 941
 942 is_format_utf8(\*OUT24h,
 943                "'\x{FF}\x{FF}'\n"x4);
 944
 945 tie my $u24i, 'UTF8Toggle', 1;
 946 $u24i = "\x{FF}" x 8;
 947
 948 format OUT24i =
 949 '^<'~~
 950 $u24i
 951 .
 952
 953 is_format_utf8(\*OUT24i,
 954                "'\x{FF}\x{FF}'\n"x4);
 955
 956 {
 957     package OS;
 958     use overload '""' => sub { ${$_[0]}; };
 959
 960     sub new {
 961         my ($class, $value) = @_;
 962         bless \$value, $class;
 963     }
 964 }
 965
 966 my $u25a = OS->new("N" x 8);
 967
 968 format OUT25a =
 969 '^<<<<<<<<'~~
 970 $u25a
 971 .
 972
 973 is_format_utf8(\*OUT25a,
 974                "'NNNNNNNN '\n");
 975
 976
 977 my $temp = "N" x 8;
 978 utf8::upgrade($temp);
 979 my $u25b = OS->new($temp);
 980
 981 format OUT25b =
 982 '^<<<<<<<<'~~
 983 $u25b
 984 .
 985
 986 is_format_utf8(\*OUT25b,
 987                "'NNNNNNNN '\n");
 988
 989 my $u25c = OS->new("\x{FF}" x 8);
 990
 991 format OUT25c =
 992 '^<<<<<<<<'~~
 993 $u25c
 994 .
 995
 996 is_format_utf8(\*OUT25c,
 997                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
 998
 999 $temp = "\x{FF}" x 8;
1000 utf8::upgrade($temp);
1001 my $u25d = OS->new($temp);
1002
1003 format OUT25d =
1004 '^<<<<<<<<'~~
1005 $u25d
1006 .
1007
1008 is_format_utf8(\*OUT25d,
1009                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
1010
1011 my $u25e = OS->new("\x{100}" x 8);
1012
1013 format OUT25e =
1014 '^<<<<<<<<'~~
1015 $u25e
1016 .
1017
1018 is_format_utf8(\*OUT25e,
1019                "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n");
1020
1021
1022 my $u25f = OS->new("N" x 8);
1023
1024 format OUT25f =
1025 '^<'~~
1026 $u25f
1027 .
1028
1029 is_format_utf8(\*OUT25f,
1030                "'NN'\n"x4);
1031
1032
1033 $temp = "N" x 8;
1034 utf8::upgrade($temp);
1035 my $u25g = OS->new($temp);
1036
1037 format OUT25g =
1038 '^<'~~
1039 $u25g
1040 .
1041
1042 is_format_utf8(\*OUT25g,
1043                "'NN'\n"x4);
1044
1045 my $u25h = OS->new("\x{FF}" x 8);
1046
1047 format OUT25h =
1048 '^<'~~
1049 $u25h
1050 .
1051
1052 is_format_utf8(\*OUT25h,
1053                "'\x{FF}\x{FF}'\n"x4);
1054
1055 $temp = "\x{FF}" x 8;
1056 utf8::upgrade($temp);
1057 my $u25i = OS->new($temp);
1058
1059 format OUT25i =
1060 '^<'~~
1061 $u25i
1062 .
1063
1064 is_format_utf8(\*OUT25i,
1065                "'\x{FF}\x{FF}'\n"x4);
1066
1067 my $u25j = OS->new("\x{100}" x 8);
1068
1069 format OUT25j =
1070 '^<'~~
1071 $u25j
1072 .
1073
1074 is_format_utf8(\*OUT25j,
1075                "'\x{100}\x{100}'\n"x4);
1076
1077 {
1078     package OS::UTF8Toggle;
1079     use overload '""' => sub {
1080         my $self = shift;
1081         $self->[1] = ! $self->[1];
1082         if ($self->[1]) {
1083             utf8::downgrade($self->[0]);
1084         } else {
1085             utf8::upgrade($self->[0]);
1086         }
1087         $self->[0];
1088     };
1089
1090     sub new {
1091         my ($class, $value, $state) = @_;
1092         bless [$value, $state], $class;
1093     }
1094 }
1095
1096
1097 my $u26a = OS::UTF8Toggle->new("N" x 8);
1098
1099 format OUT26a =
1100 '^<<<<<<<<'~~
1101 $u26a
1102 .
1103
1104 is_format_utf8(\*OUT26a,
1105                "'NNNNNNNN '\n");
1106
1107
1108 my $u26b = OS::UTF8Toggle->new("N" x 8, 1);
1109
1110 format OUT26b =
1111 '^<<<<<<<<'~~
1112 $u26b
1113 .
1114
1115 is_format_utf8(\*OUT26b,
1116                "'NNNNNNNN '\n");
1117
1118 my $u26c = OS::UTF8Toggle->new("\x{FF}" x 8);
1119
1120 format OUT26c =
1121 '^<<<<<<<<'~~
1122 $u26c
1123 .
1124
1125 is_format_utf8(\*OUT26c,
1126                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
1127
1128 my $u26d = OS::UTF8Toggle->new("\x{FF}" x 8, 1);
1129
1130 format OUT26d =
1131 '^<<<<<<<<'~~
1132 $u26d
1133 .
1134
1135 is_format_utf8(\*OUT26d,
1136                "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n");
1137
1138
1139 my $u26f = OS::UTF8Toggle->new("N" x 8);
1140
1141 format OUT26f =
1142 '^<'~~
1143 $u26f
1144 .
1145
1146 is_format_utf8(\*OUT26f,
1147                "'NN'\n"x4);
1148
1149
1150 my $u26g = OS::UTF8Toggle->new("N" x 8, 1);
1151
1152 format OUT26g =
1153 '^<'~~
1154 $u26g
1155 .
1156
1157 is_format_utf8(\*OUT26g,
1158                "'NN'\n"x4);
1159
1160 my $u26h = OS::UTF8Toggle->new("\x{FF}" x 8);
1161
1162 format OUT26h =
1163 '^<'~~
1164 $u26h
1165 .
1166
1167 is_format_utf8(\*OUT26h,
1168                "'\x{FF}\x{FF}'\n"x4);
1169
1170 my $u26i = OS::UTF8Toggle->new("\x{FF}" x 8, 1);
1171
1172 format OUT26i =
1173 '^<'~~
1174 $u26i
1175 .
1176
1177 is_format_utf8(\*OUT26i,
1178                "'\x{FF}\x{FF}'\n"x4);
1179
1180
1181
1182 {
1183     my $zero = $$ - $$;
1184
1185     package Number;
1186
1187     sub TIESCALAR {
1188         my $class = shift;
1189         my $value = shift;
1190         return bless \$value, $class;
1191     }
1192
1193     # The return value should always be SvNOK() only:
1194     sub FETCH {
1195         my $self = shift;
1196         # avoid "" getting converted to "0" and thus
1197         # causing an infinite loop
1198         return "" unless length ($$self);
1199         return $$self - 0.5 + $zero + 0.5;
1200     }
1201
1202    sub STORE {
1203        my $self = shift;
1204        $$self = shift;
1205     }
1206
1207    package ONumber;
1208
1209    use overload '""' => sub {
1210         my $self = shift;
1211         return $$self - 0.5 + $zero + 0.5;
1212     };
1213
1214     sub new {
1215        my $class = shift;
1216        my $value = shift;
1217        return bless \$value, $class;
1218    }
1219 }
1220
1221 my $v27a = 1/256;
1222
1223 format OUT27a =
1224 '^<<<<<<<<<'~~
1225 $v27a
1226 .
1227
1228 is_format_utf8(\*OUT27a,
1229                "'0.00390625'\n");
1230
1231 my $v27b = 1/256;
1232
1233 format OUT27b =
1234 '^<'~~
1235 $v27b
1236 .
1237
1238 is_format_utf8(\*OUT27b,
1239                "'0.'\n'00'\n'39'\n'06'\n'25'\n");
1240
1241 tie my $v27c, 'Number', 1/256;
1242
1243 format OUT27c =
1244 '^<<<<<<<<<'~~
1245 $v27c
1246 .
1247
1248 is_format_utf8(\*OUT27c,
1249                "'0.00390625'\n");
1250
1251 my $v27d = 1/256;
1252
1253 format OUT27d =
1254 '^<'~~
1255 $v27d
1256 .
1257
1258 is_format_utf8(\*OUT27d,
1259                "'0.'\n'00'\n'39'\n'06'\n'25'\n");
1260
1261 my $v27e = ONumber->new(1/256);
1262
1263 format OUT27e =
1264 '^<<<<<<<<<'~~
1265 $v27e
1266 .
1267
1268 is_format_utf8(\*OUT27e,
1269                "'0.00390625'\n");
1270
1271 my $v27f = ONumber->new(1/256);
1272
1273 format OUT27f =
1274 '^<'~~
1275 $v27f
1276 .
1277
1278 is_format_utf8(\*OUT27f,
1279                "'0.'\n'00'\n'39'\n'06'\n'25'\n");
1280
1281 {
1282     package Ref;
1283     use overload '""' => sub {
1284         return ${$_[0]};
1285     };
1286
1287     sub new {
1288        my $class = shift;
1289        my $value = shift;
1290        return bless \$value, $class;
1291    }
1292 }
1293
1294 my $v28a = {};
1295
1296 format OUT28a =
1297 '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~
1298 $v28a
1299 .
1300
1301
1302 # 'HASH(0x1716b60)     '
1303 my $qr_hash   = qr/^'HASH\(0x[0-9a-f]+\)\s+'\n$/;
1304
1305 # 'HASH'
1306 # '(0x1'
1307 # '716b'
1308 # 'c0) '
1309 my $qr_hash_m = qr/^'HASH'\n('[0-9a-fx() ]{4}'\n)+$/;
1310
1311 like_format_utf8(\*OUT28a, $qr_hash);
1312
1313 my $v28b = {};
1314
1315 format OUT28b =
1316 '^<<<'~~
1317 $v28b
1318 .
1319
1320 like_format_utf8(\*OUT28b, $qr_hash_m);
1321
1322
1323 tie my $v28c, 'Tie::StdScalar';
1324 $v28c = {};
1325
1326 format OUT28c =
1327 '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~
1328 $v28c
1329 .
1330
1331 like_format_utf8(\*OUT28c, $qr_hash);
1332
1333 tie my $v28d, 'Tie::StdScalar';
1334 $v28d = {};
1335
1336 format OUT28d =
1337 '^<<<'~~
1338 $v28d
1339 .
1340
1341 like_format_utf8(\*OUT28d, $qr_hash_m);
1342
1343 my $v28e = Ref->new({});
1344
1345 format OUT28e =
1346 '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~
1347 $v28e
1348 .
1349
1350 like_format_utf8(\*OUT28e, $qr_hash);
1351
1352 my $v28f = Ref->new({});
1353
1354 format OUT28f =
1355 '^<<<'~~
1356 $v28f
1357 .
1358
1359 like_format_utf8(\*OUT28f, $qr_hash_m);
1360
1361
1362
1363 {
1364   package Count;
1365
1366   sub TIESCALAR {
1367     my $class = shift;
1368     bless [shift, 0, 0], $class;
1369   }
1370
1371   sub FETCH {
1372     my $self = shift;
1373     ++$self->[1];
1374     $self->[0];
1375   }
1376
1377   sub STORE {
1378     my $self = shift;
1379     ++$self->[2];
1380     $self->[0] = shift;
1381   }
1382 }
1383
1384 {
1385   my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a}
1386     my ($pound, $pm) = ("\xA3", "\xB1");
1387
1388   foreach my $first ('N', $pound, $pound_utf8) {
1389     foreach my $base ('N', $pm, $pm_utf8) {
1390       foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n",
1391                           "$base\nMoo!\n",) {
1392         foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
1393           my ($format, $re) = @$_;
1394           $format = "1^*2 3${format}4";
1395           foreach my $class ('', 'Count') {
1396             my $name = qq{swrite("$format", "$first", "$second") class="$class"};
1397             $name =~ s/\n/\\n/g;
1398             $name =~ s{(.)}{
1399                         ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
1400                     }ge;
1401
1402             $first =~ /(.+)/ or die $first;
1403             my $expect = "1${1}2";
1404             $second =~ $re or die $second;
1405             $expect .= " 3${1}4";
1406
1407             if ($class) {
1408               my $copy1 = $first;
1409               my $copy2;
1410               tie $copy2, $class, $second;
1411               is swrite("$format", $copy1, $copy2), $expect, $name;
1412               my $obj = tied $copy2;
1413               is $obj->[1], 1, 'value read exactly once';
1414             } else {
1415               my ($copy1, $copy2) = ($first, $second);
1416               is swrite("$format", $copy1, $copy2), $expect, $name;
1417             }
1418           }
1419         }
1420       }
1421     }
1422   }
1423 }
1424
1425 {
1426   # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
1427   # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
1428   # be doing something similarly out of bounds on everything from 5.000
1429   my $ref = [];
1430   my $exp = ">$ref<";
1431   is swrite('>^*<', $ref), $exp;
1432   $ref = [];
1433   my $exp = ">$ref<";
1434   is swrite('>@*<', $ref), $exp;
1435 }
1436
1437 format EMPTY =
1438 .
1439
1440 my $test = curr_test();
1441
1442 format Comment =
1443 ok @<<<<<
1444 $test
1445 .
1446
1447
1448 # RT #8698 format bug with undefined _TOP
1449
1450 open STDOUT_DUP, ">&STDOUT";
1451 my $oldfh = select STDOUT_DUP;
1452 $= = 10;
1453 {
1454   local $~ = "Comment";
1455   write;
1456   curr_test($test + 1);
1457   is $-, 9;
1458   is $^, "STDOUT_DUP_TOP";
1459 }
1460 select $oldfh;
1461 close STDOUT_DUP;
1462
1463 *CmT =  *{$::{Comment}}{FORMAT};
1464 ok  defined *{$::{CmT}}{FORMAT}, "glob assign";
1465
1466
1467 # RT #91032: Check that "non-real" strings like tie and overload work,
1468 # especially that they re-compile the pattern on each FETCH, and that
1469 # they don't overrun the buffer
1470
1471
1472 {
1473     package RT91032;
1474
1475     sub TIESCALAR { bless [] }
1476     my $i = 0;
1477     sub FETCH { $i++; "A$i @> Z\n" }
1478
1479     use overload '""' => \&FETCH;
1480
1481     tie my $f, 'RT91032';
1482
1483     formline $f, "a";
1484     formline $f, "bc";
1485     ::is $^A, "A1  a Z\nA2 bc Z\n", "RT 91032: tied";
1486     $^A = '';
1487
1488     my $g = bless []; # has overloaded stringify
1489     formline $g, "de";
1490     formline $g, "f";
1491     ::is $^A, "A3 de Z\nA4  f Z\n", "RT 91032: overloaded";
1492     $^A = '';
1493
1494     my $h = [];
1495     formline $h, "junk1";
1496     formline $h, "junk2";
1497     ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref";
1498     ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok";
1499     ::is $^A, "$h$h","RT 91032: stringified array";
1500     $^A = '';
1501
1502     # used to overwrite the ~~ in the *original SV with spaces. Naughty!
1503
1504     my $orig = my $format = "^<<<<< ~~\n";
1505     my $abc = "abc";
1506     formline $format, $abc;
1507     $^A ='';
1508     ::is $format, $orig, "RT91032: don't overwrite orig format string";
1509
1510     # check that ~ and ~~ are displayed correctly as whitespace,
1511     # under the influence of various different types of border
1512
1513     for my $n (1,2) {
1514         for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
1515             for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
1516                 my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
1517                 my $sfmt = ($fmt =~ s/~/ /gr);
1518                 my ($a, $bc, $stop);
1519                 ($a, $bc, $stop) = ('a', 'bc', 's');
1520                 # $stop is to stop '~~' deleting the whole line
1521                 formline $sfmt, $stop, $a, $bc;
1522                 my $exp = $^A;
1523                 $^A = '';
1524                 ($a, $bc, $stop) = ('a', 'bc', 's');
1525                 formline $fmt, $stop, $a, $bc;
1526                 my $got = $^A;
1527                 $^A = '';
1528                 $fmt =~ s/\n/\\n/;
1529                 ::is($got, $exp, "chop munging: [$fmt]");
1530             }
1531         }
1532     }
1533 }
1534
1535 # check that '~  (delete current line if empty) works when
1536 # the target gets upgraded to uft8 (and re-allocated) midstream.
1537
1538 {
1539     my $format = "\x{100}@~\n"; # format is utf8
1540     # this target is not utf8, but will expand (and get reallocated)
1541     # when upgraded to utf8.
1542     my $orig = "\x80\x81\x82";
1543     local $^A = $orig;
1544     my $empty = "";
1545     formline $format, $empty;
1546     is $^A , $orig, "~ and realloc";
1547
1548     # check similarly that trailing blank removal works ok
1549
1550     $format = "@<\n\x{100}"; # format is utf8
1551     chop $format;
1552     $orig = "   ";
1553     $^A = $orig;
1554     formline $format, "  ";
1555     is $^A, "$orig\n", "end-of-line blanks and realloc";
1556
1557     # and check this doesn't overflow the buffer
1558
1559     local $^A = '';
1560     $format = "@* @####\n";
1561     $orig = "x" x 100 . "\n";
1562     formline $format, $orig, 12345;
1563     is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow";
1564
1565     # make sure it can cope with formats > 64k
1566
1567     $format = 'x' x 65537;
1568     $^A = '';
1569     formline $format;
1570     # don't use 'is' here, as the diag output will be too long!
1571     ok $^A eq $format, ">64K";
1572 }
1573
1574
1575 SKIP: {
1576     skip_if_miniperl('miniperl does not support scalario');
1577     my $buf = "";
1578     open my $fh, ">", \$buf;
1579     my $old_fh = select $fh;
1580     local $~ = "CmT";
1581     write;
1582     select $old_fh;
1583     close $fh;
1584     is $buf, "ok $test\n", "write to duplicated format";
1585 }
1586
1587 format caret_A_test_TOP =
1588 T
1589 .
1590
1591 format caret_A_test =
1592 L1
1593 L2
1594 L3
1595 L4
1596 .
1597
1598 SKIP: {
1599     skip_if_miniperl('miniperl does not support scalario');
1600     my $buf = "";
1601     open my $fh, ">", \$buf;
1602     my $old_fh = select $fh;
1603     local $^ = "caret_A_test_TOP";
1604     local $~ = "caret_A_test";
1605     local $= = 3;
1606     local $^A = "A1\nA2\nA3\nA4\n";
1607     write;
1608     select $old_fh;
1609     close $fh;
1610     is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n",
1611                     "assign to ^A sets FmLINES";
1612 }
1613
1614 fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings');
1615 #!./perl
1616
1617 use strict;
1618 use warnings; # crashes!
1619
1620 format =
1621 .
1622
1623 write;
1624
1625 format =
1626 .
1627
1628 write;
1629 EOP
1630
1631 fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments');
1632 use strict;
1633 use warnings;
1634 my $zamm = ['crunch_eth'];
1635 formline $zamm;
1636 printf ">%s<\n", ref $zamm;
1637 print "$zamm->[0]\n";
1638 EOP
1639
1640 # [perl #73690]
1641
1642 select +(select(RT73690), do {
1643     open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1644     format RT73690 =
1645 @<< @<<
1646 11, 22
1647 .
1648
1649     my @ret;
1650
1651     @ret = write;
1652     is(scalar(@ret), 1);
1653     ok($ret[0]);
1654     @ret = scalar(write);
1655     is(scalar(@ret), 1);
1656     ok($ret[0]);
1657     @ret = write(RT73690);
1658     is(scalar(@ret), 1);
1659     ok($ret[0]);
1660     @ret = scalar(write(RT73690));
1661     is(scalar(@ret), 1);
1662     ok($ret[0]);
1663
1664     @ret = ('a', write, 'z');
1665     is(scalar(@ret), 3);
1666     is($ret[0], 'a');
1667     ok($ret[1]);
1668     is($ret[2], 'z');
1669     @ret = ('b', scalar(write), 'y');
1670     is(scalar(@ret), 3);
1671     is($ret[0], 'b');
1672     ok($ret[1]);
1673     is($ret[2], 'y');
1674     @ret = ('c', write(RT73690), 'x');
1675     is(scalar(@ret), 3);
1676     is($ret[0], 'c');
1677     ok($ret[1]);
1678     is($ret[2], 'x');
1679     @ret = ('d', scalar(write(RT73690)), 'w');
1680     is(scalar(@ret), 3);
1681     is($ret[0], 'd');
1682     ok($ret[1]);
1683     is($ret[2], 'w');
1684
1685     @ret = do { write; 'foo' };
1686     is(scalar(@ret), 1);
1687     is($ret[0], 'foo');
1688     @ret = do { scalar(write); 'bar' };
1689     is(scalar(@ret), 1);
1690     is($ret[0], 'bar');
1691     @ret = do { write(RT73690); 'baz' };
1692     is(scalar(@ret), 1);
1693     is($ret[0], 'baz');
1694     @ret = do { scalar(write(RT73690)); 'quux' };
1695     is(scalar(@ret), 1);
1696     is($ret[0], 'quux');
1697
1698     @ret = ('a', do { write; 'foo' }, 'z');
1699     is(scalar(@ret), 3);
1700     is($ret[0], 'a');
1701     is($ret[1], 'foo');
1702     is($ret[2], 'z');
1703     @ret = ('b', do { scalar(write); 'bar' }, 'y');
1704     is(scalar(@ret), 3);
1705     is($ret[0], 'b');
1706     is($ret[1], 'bar');
1707     is($ret[2], 'y');
1708     @ret = ('c', do { write(RT73690); 'baz' }, 'x');
1709     is(scalar(@ret), 3);
1710     is($ret[0], 'c');
1711     is($ret[1], 'baz');
1712     is($ret[2], 'x');
1713     @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w');
1714     is(scalar(@ret), 3);
1715     is($ret[0], 'd');
1716     is($ret[1], 'quux');
1717     is($ret[2], 'w');
1718
1719     close RT73690 or die "Could not close: $!";
1720 })[0];
1721
1722 select +(select(RT73690_2), do {
1723     open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1724     format RT73690_2 =
1725 @<< @<<
1726 return
1727 .
1728
1729     my @ret;
1730
1731     @ret = write;
1732     is(scalar(@ret), 1);
1733     ok(!$ret[0]);
1734     @ret = scalar(write);
1735     is(scalar(@ret), 1);
1736     ok(!$ret[0]);
1737     @ret = write(RT73690_2);
1738     is(scalar(@ret), 1);
1739     ok(!$ret[0]);
1740     @ret = scalar(write(RT73690_2));
1741     is(scalar(@ret), 1);
1742     ok(!$ret[0]);
1743
1744     @ret = ('a', write, 'z');
1745     is(scalar(@ret), 3);
1746     is($ret[0], 'a');
1747     ok(!$ret[1]);
1748     is($ret[2], 'z');
1749     @ret = ('b', scalar(write), 'y');
1750     is(scalar(@ret), 3);
1751     is($ret[0], 'b');
1752     ok(!$ret[1]);
1753     is($ret[2], 'y');
1754     @ret = ('c', write(RT73690_2), 'x');
1755     is(scalar(@ret), 3);
1756     is($ret[0], 'c');
1757     ok(!$ret[1]);
1758     is($ret[2], 'x');
1759     @ret = ('d', scalar(write(RT73690_2)), 'w');
1760     is(scalar(@ret), 3);
1761     is($ret[0], 'd');
1762     ok(!$ret[1]);
1763     is($ret[2], 'w');
1764
1765     @ret = do { write; 'foo' };
1766     is(scalar(@ret), 1);
1767     is($ret[0], 'foo');
1768     @ret = do { scalar(write); 'bar' };
1769     is(scalar(@ret), 1);
1770     is($ret[0], 'bar');
1771     @ret = do { write(RT73690_2); 'baz' };
1772     is(scalar(@ret), 1);
1773     is($ret[0], 'baz');
1774     @ret = do { scalar(write(RT73690_2)); 'quux' };
1775     is(scalar(@ret), 1);
1776     is($ret[0], 'quux');
1777
1778     @ret = ('a', do { write; 'foo' }, 'z');
1779     is(scalar(@ret), 3);
1780     is($ret[0], 'a');
1781     is($ret[1], 'foo');
1782     is($ret[2], 'z');
1783     @ret = ('b', do { scalar(write); 'bar' }, 'y');
1784     is(scalar(@ret), 3);
1785     is($ret[0], 'b');
1786     is($ret[1], 'bar');
1787     is($ret[2], 'y');
1788     @ret = ('c', do { write(RT73690_2); 'baz' }, 'x');
1789     is(scalar(@ret), 3);
1790     is($ret[0], 'c');
1791     is($ret[1], 'baz');
1792     is($ret[2], 'x');
1793     @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w');
1794     is(scalar(@ret), 3);
1795     is($ret[0], 'd');
1796     is($ret[1], 'quux');
1797     is($ret[2], 'w');
1798
1799     close RT73690_2 or die "Could not close: $!";
1800 })[0];
1801
1802 open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1803 select +(select(UNDEF), $~ = "UNDEFFORMAT")[0];
1804 format UNDEFFORMAT =
1805 @
1806 undef *UNDEFFORMAT
1807 .
1808 write UNDEF;
1809 pass "active format cannot be freed";
1810
1811 select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0];
1812 format UNDEFFORMAT2 =
1813 @
1814 close UNDEF or die "Could not close: $!"; undef *UNDEF
1815 .
1816 write UNDEF;
1817 pass "freeing current handle in format";
1818 undef $^A;
1819
1820 ok !eval q|
1821 format foo {
1822 @<<<
1823 $a
1824 }
1825 ;1
1826 |, 'format foo { ... } is not allowed';
1827
1828 ok !eval q|
1829 format =
1830 @<<<
1831 }
1832 ;1
1833 |, 'format = ... } is not allowed';
1834
1835 open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1836 format NEST =
1837 @<<<
1838 {
1839     my $birds = "birds";
1840     local *NEST = *BIRDS{FORMAT};
1841     write NEST;
1842     format BIRDS =
1843 @<<<<<
1844 $birds;
1845 .
1846     "nest"
1847 }
1848 .
1849 write NEST;
1850 close NEST or die "Could not close: $!";
1851 is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats';
1852
1853 # A compilation error should not create a format
1854 eval q|
1855 format ERROR =
1856 @
1857 @_ =~ s///
1858 .
1859 |;
1860 eval { write ERROR };
1861 like $@, qr'Undefined format',
1862     'formats with compilation errors are not created';
1863
1864 # This syntax error used to cause a crash, double free, or a least
1865 # a bad read.
1866 # See the long-winded explanation at:
1867 #   https://rt.perl.org/rt3/Ticket/Display.html?id=43425#txn-1144500
1868 eval q|
1869 format =
1870 @
1871 use;format
1872 strict
1873 .
1874 |;
1875 pass('no crash with invalid use/format inside format');
1876
1877
1878 # Low-precedence operators on argument line
1879 format AND =
1880 @
1881 0 and die
1882 .
1883 $- = $=;
1884 ok eval { local $~ = "AND"; print "# "; write; 1 },
1885     "low-prec ops on arg line" or diag $@;
1886
1887 # Anonymous hashes
1888 open(HASH, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1889 format HASH =
1890 @<<<
1891 ${{qw[ Sun 0 Mon 1 Tue 2 Wed 3 Thu 4 Fri 5 Sat 6 ]}}{"Wed"}
1892 .
1893 write HASH;
1894 close HASH or die "Could not close: $!";
1895 is cat('Op_write.tmp'), "3\n", 'anonymous hashes';
1896
1897 open(HASH2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1898 format HASH2 =
1899 @<<<
1900 +{foo=>"bar"}
1901 .
1902 write HASH2;
1903 close HASH2 or die "Could not close: $!";
1904 is cat('Op_write.tmp'), "HASH\n", '+{...} is interpreted as anon hash';
1905
1906 # Anonymous hashes
1907 open(BLOCK, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1908 format BLOCK =
1909 @<<< @<<<
1910 {foo=>"bar"} # this is a block, not a hash!
1911 .
1912 write BLOCK;
1913 close BLOCK or die "Could not close: $!";
1914 is cat('Op_write.tmp'), "foo  bar\n", 'initial { is always BLOCK';
1915
1916 # pragmata inside argument line
1917 open(STRICT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
1918 format STRICT =
1919 @<<<
1920 no strict; $foo
1921 .
1922 $::foo = 'oof::$';
1923 write STRICT;
1924 close STRICT or die "Could not close: $!";
1925 is cat('Op_write.tmp'), "oof:\n", 'pragmata on format line';
1926
1927 SKIP: {
1928    skip "no weak refs" unless eval { require Scalar::Util };
1929    sub Potshriggley {
1930 format Potshriggley =
1931 .
1932    }
1933    Scalar::Util::weaken(my $x = *Potshriggley{FORMAT});
1934    undef *Potshriggley;
1935    is $x, undef, 'formats in subs do not leak';
1936 }
1937
1938
1939 #############################
1940 ## Section 4
1941 ## Add new tests *above* here
1942 #############################
1943
1944 # scary format testing from H.Merijn Brand
1945
1946 # Just a complete test for format, including top-, left- and bottom marging
1947 # and format detection through glob entries
1948
1949 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
1950     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
1951   $test = curr_test();
1952  SKIP: {
1953       skip "'|-' and '-|' not supported", $tests - $test + 1;
1954   }
1955   exit(0);
1956 }
1957
1958
1959 $^  = "STDOUT_TOP";
1960 $=  =  7;               # Page length
1961 $-  =  0;               # Lines left
1962 my $ps = $^L; $^L = ""; # Catch the page separator
1963 my $tm =  1;            # Top margin (empty lines before first output)
1964 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
1965 my $lm =  4;            # Left margin (indent in spaces)
1966
1967 # -----------------------------------------------------------------------
1968 #
1969 # execute the rest of the script in a child process. The parent reads the
1970 # output from the child and compares it with <DATA>.
1971
1972 my @data = <DATA>;
1973
1974 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
1975
1976 my $opened = open FROM_CHILD, "-|";
1977 unless (defined $opened) {
1978     fail "open gave $!";
1979     exit 0;
1980 }
1981
1982 if ($opened) {
1983     # in parent here
1984
1985     pass 'open';
1986     my $s = " " x $lm;
1987     while (<FROM_CHILD>) {
1988         unless (@data) {
1989             fail 'too much output';
1990             exit;
1991         }
1992         s/^/$s/;
1993         my $exp = shift @data;
1994         is $_, $exp;
1995     }
1996     close FROM_CHILD;
1997     is "@data", "", "correct length of output";
1998     exit;
1999 }
2000
2001 # in child here
2002 $::NO_ENDING = 1;
2003
2004     select ((select (STDOUT), $| = 1)[0]);
2005 $tm = "\n" x $tm;
2006 $= -= $bm + 1; # count one for the trailing "----"
2007 my $lastmin = 0;
2008
2009 my @E;
2010
2011 sub wryte
2012 {
2013     $lastmin = $-;
2014     write;
2015     } # wryte;
2016
2017 sub footer
2018 {
2019     $% == 1 and return "";
2020
2021     $lastmin < $= and print "\n" x $lastmin;
2022     print "\n" x $bm, "----\n", $ps;
2023     $lastmin = $-;
2024     "";
2025     } # footer
2026
2027 # Yes, this is sick ;-)
2028 format TOP =
2029 @* ~
2030 @{[footer]}
2031 @* ~
2032 $tm
2033 .
2034
2035 format ENTRY =
2036 @ @<<<<~~
2037 @{(shift @E)||["",""]}
2038 .
2039
2040 format EOR =
2041 - -----
2042 .
2043
2044 sub has_format ($)
2045 {
2046     my $fmt = shift;
2047     exists $::{$fmt} or return 0;
2048     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
2049     open my $null, "> /dev/null" or die;
2050     my $fh = select $null;
2051     local $~ = $fmt;
2052     eval "write";
2053     select $fh;
2054     $@?0:1;
2055     } # has_format
2056
2057 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
2058 has_format ("ENTRY") or die "No format defined for ENTRY";
2059 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
2060                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
2061     @E = @$e;
2062     local $~ = "ENTRY";
2063     wryte;
2064     has_format ("EOR") or next;
2065     local $~ = "EOR";
2066     wryte;
2067     }
2068 if (has_format ("EOF")) {
2069     local $~ = "EOF";
2070     wryte;
2071     }
2072
2073 close STDOUT;
2074
2075 # That was test 48.
2076
2077 __END__
2078
2079     1 Test1
2080     2 Test2
2081     3 Test3
2082
2083
2084     ----
2085     \f
2086     4 Test4
2087     5 Test5
2088     6 Test6
2089
2090
2091     ----
2092     \f
2093     7 Test7
2094     - -----
2095
2096
2097
2098     ----
2099     \f
2100     1 1tseT
2101     2 2tseT
2102     3 3tseT
2103
2104
2105     ----
2106     \f
2107     4 4tseT
2108     5 5tseT
2109     - -----