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