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