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