t/op/write.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 # read in a file
  10 sub cat {
  11     my $file = shift;
  12     local $/;
  13     open my $fh, $file or die "can't open '$file': $!";
  14     my $data = <$fh>;
  15     close $fh;
  16     $data;
  17 }
  18
  19 #-- testing numeric fields in all variants (WL)
  20
  21 sub swrite {
  22     my $format = shift;
  23     local $^A = ""; # don't litter, use a local bin
  24     formline( $format, @_ );
  25     return $^A;
  26 }
  27
  28 my @NumTests = (
  29     # [ format, value1, expected1, value2, expected2, .... ]
  30     [ '@###',           0,   '   0',         1, '   1',     9999.6, '####',
  31                 9999.4999,   '9999',    -999.6, '####',     1e+100, '####' ],
  32
  33     [ '@0##',           0,   '0000',         1, '0001',     9999.6, '####',
  34                 -999.4999,   '-999',    -999.6, '####',     1e+100, '####' ],
  35
  36     [ '^###',           0,   '   0',     undef, '    ' ],
  37
  38     [ '^0##',           0,   '0000',     undef, '    ' ],
  39
  40     [ '@###.',          0,  '   0.',         1, '   1.',    9999.6, '#####',
  41                 9999.4999,  '9999.',    -999.6, '#####' ],
  42
  43     [ '@##.##',         0, '  0.00',         1, '  1.00',  999.996, '######',
  44                 999.99499, '999.99',      -100, '######' ],
  45
  46     [ '@0#.##',         0, '000.00',         1, '001.00',       10, '010.00',
  47                   -0.0001, qr/^[\-0]00\.00$/ ],
  48
  49 );
  50
  51
  52 my $num_tests = 0;
  53 for my $tref ( @NumTests ){
  54     $num_tests += (@$tref - 1)/2;
  55 }
  56 #---------------------------------------------------------
  57
  58 # number of tests in section 1
  59 my $bas_tests = 20;
  60
  61 # number of tests in section 3
  62 my $bug_tests = 4;
  63
  64 # number of tests in section 4
  65 my $hmb_tests = 35;
  66
  67 my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests;
  68
  69 plan $tests;
  70
  71 ############
  72 ## Section 1
  73 ############
  74
  75 format OUT =
  76 the quick brown @<<
  77 $fox
  78 jumped
  79 @*
  80 $multiline
  81 ^<<<<<<<<<
  82 $foo
  83 ^<<<<<<<<<
  84 $foo
  85 ^<<<<<<...
  86 $foo
  87 now @<<the@>>>> for all@|||||men to come @<<<<
  88 {
  89     'i' . 's', "time\n", $good, 'to'
  90 }
  91 .
  92
  93 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
  94 END { 1 while unlink 'Op_write.tmp' }
  95
  96 $fox = 'foxiness';
  97 $good = 'good';
  98 $multiline = "forescore\nand\nseven years\n";
  99 $foo = 'when in the course of human events it becomes necessary';
 100 write(OUT);
 101 close OUT or die "Could not close: $!";
 102
 103 $right =
 104 "the quick brown fox
 105 jumped
 106 forescore
 107 and
 108 seven years
 109 when in
 110 the course
 111 of huma...
 112 now is the time for all good men to come to\n";
 113
 114 if (cat('Op_write.tmp') eq $right)
 115     { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
 116 else
 117     { print "not ok 1\n"; }
 118
 119 $fox = 'wolfishness';
 120 my $fox = 'foxiness';           # Test a lexical variable.
 121
 122 format OUT2 =
 123 the quick brown @<<
 124 $fox
 125 jumped
 126 @*
 127 $multiline
 128 ^<<<<<<<<< ~~
 129 $foo
 130 now @<<the@>>>> for all@|||||men to come @<<<<
 131 'i' . 's', "time\n", $good, 'to'
 132 .
 133
 134 open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
 135
 136 $good = 'good';
 137 $multiline = "forescore\nand\nseven years\n";
 138 $foo = 'when in the course of human events it becomes necessary';
 139 write(OUT2);
 140 close OUT2 or die "Could not close: $!";
 141
 142 $right =
 143 "the quick brown fox
 144 jumped
 145 forescore
 146 and
 147 seven years
 148 when in
 149 the course
 150 of human
 151 events it
 152 becomes
 153 necessary
 154 now is the time for all good men to come to\n";
 155
 156 if (cat('Op_write.tmp') eq $right)
 157     { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
 158 else
 159     { print "not ok 2\n"; }
 160
 161 eval <<'EOFORMAT';
 162 format OUT2 =
 163 the brown quick @<<
 164 $fox
 165 jumped
 166 @*
 167 $multiline
 168 and
 169 ^<<<<<<<<< ~~
 170 $foo
 171 now @<<the@>>>> for all@|||||men to come @<<<<
 172 'i' . 's', "time\n", $good, 'to'
 173 .
 174 EOFORMAT
 175
 176 open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 177
 178 $fox = 'foxiness';
 179 $good = 'good';
 180 $multiline = "forescore\nand\nseven years\n";
 181 $foo = 'when in the course of human events it becomes necessary';
 182 write(OUT2);
 183 close OUT2 or die "Could not close: $!";
 184
 185 $right =
 186 "the brown quick fox
 187 jumped
 188 forescore
 189 and
 190 seven years
 191 and
 192 when in
 193 the course
 194 of human
 195 events it
 196 becomes
 197 necessary
 198 now is the time for all good men to come to\n";
 199
 200 if (cat('Op_write.tmp') eq $right)
 201     { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
 202 else
 203     { print "not ok 3\n"; }
 204
 205 # formline tests
 206
 207 $mustbe = <<EOT;
 208 @ a
 209 @> ab
 210 @>> abc
 211 @>>>  abc
 212 @>>>>   abc
 213 @>>>>>    abc
 214 @>>>>>>     abc
 215 @>>>>>>>      abc
 216 @>>>>>>>>       abc
 217 @>>>>>>>>>        abc
 218 @>>>>>>>>>>         abc
 219 EOT
 220
 221 $was1 = $was2 = '';
 222 for (0..10) {
 223   # lexical picture
 224   $^A = '';
 225   my $format1 = '@' . '>' x $_;
 226   formline $format1, 'abc';
 227   $was1 .= "$format1 $^A\n";
 228   # global
 229   $^A = '';
 230   local $format2 = '@' . '>' x $_;
 231   formline $format2, 'abc';
 232   $was2 .= "$format2 $^A\n";
 233 }
 234 print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
 235 print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
 236
 237 $^A = '';
 238
 239 # more test
 240
 241 format OUT3 =
 242 ^<<<<<<...
 243 $foo
 244 .
 245
 246 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 247
 248 $foo = 'fit          ';
 249 write(OUT3);
 250 close OUT3 or die "Could not close: $!";
 251
 252 $right =
 253 "fit\n";
 254
 255 if (cat('Op_write.tmp') eq $right)
 256     { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
 257 else
 258     { print "not ok 6\n"; }
 259
 260 # test lexicals and globals
 261 {
 262     my $this = "ok";
 263     our $that = 7;
 264     format LEX =
 265 @<<@|
 266 $this,$that
 267 .
 268     open(LEX, ">&STDOUT") or die;
 269     write LEX;
 270     $that = 8;
 271     write LEX;
 272     close LEX or die "Could not close: $!";
 273 }
 274 # LEX_INTERPNORMAL test
 275 my %e = ( a => 1 );
 276 format OUT4 =
 277 @<<<<<<
 278 "$e{a}"
 279 .
 280 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
 281 write (OUT4);
 282 close  OUT4 or die "Could not close: $!";
 283 if (cat('Op_write.tmp') eq "1\n") {
 284     print "ok 9\n";
 285     1 while unlink "Op_write.tmp";
 286     }
 287 else {
 288     print "not ok 9\n";
 289     }
 290
 291 eval <<'EOFORMAT';
 292 format OUT10 =
 293 @####.## @0###.##
 294 $test1, $test1
 295 .
 296 EOFORMAT
 297
 298 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 299
 300 $test1 = 12.95;
 301 write(OUT10);
 302 close OUT10 or die "Could not close: $!";
 303
 304 $right = "   12.95 00012.95\n";
 305 if (cat('Op_write.tmp') eq $right)
 306     { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
 307 else
 308     { print "not ok 10\n"; }
 309
 310 eval <<'EOFORMAT';
 311 format OUT11 =
 312 @0###.##
 313 $test1
 314 @ 0#
 315 $test1
 316 @0 #
 317 $test1
 318 .
 319 EOFORMAT
 320
 321 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 322
 323 $test1 = 12.95;
 324 write(OUT11);
 325 close OUT11 or die "Could not close: $!";
 326
 327 $right =
 328 "00012.95
 329 1 0#
 330 10 #\n";
 331 if (cat('Op_write.tmp') eq $right)
 332     { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
 333 else
 334     { print "not ok 11\n"; }
 335
 336 {
 337     my $el;
 338     format OUT12 =
 339 ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
 340 $el
 341 .
 342     my %hash = (12 => 3);
 343     open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 344
 345     for $el (keys %hash) {
 346         write(OUT12);
 347     }
 348     close OUT12 or die "Could not close: $!";
 349     print cat('Op_write.tmp');
 350
 351 }
 352
 353 {
 354     # Bug report and testcase by Alexey Tourbin
 355     use Tie::Scalar;
 356     my $v;
 357     tie $v, 'Tie::StdScalar';
 358     $v = 13;
 359     format OUT13 =
 360 ok ^<<<<<<<<< ~~
 361 $v
 362 .
 363     open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 364     write(OUT13);
 365     close OUT13 or die "Could not close: $!";
 366     print cat('Op_write.tmp');
 367 }
 368
 369 {   # test 14
 370     # Bug #24774 format without trailing \n failed assertion, but this
 371     # must fail since we have a trailing ; in the eval'ed string (WL)
 372     my @v = ('k');
 373     eval "format OUT14 = \n@\n\@v";
 374     print +($@ && $@ =~ /Format not terminated/)
 375       ? "ok 14\n" : "not ok 14 $@\n";
 376
 377 }
 378
 379 {   # test 15
 380     # text lost in ^<<< field with \r in value (WL)
 381     my $txt = "line 1\rline 2";
 382     format OUT15 =
 383 ^<<<<<<<<<<<<<<<<<<
 384 $txt
 385 ^<<<<<<<<<<<<<<<<<<
 386 $txt
 387 .
 388     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 389     write(OUT15);
 390     close OUT15 or die "Could not close: $!";
 391     my $res = cat('Op_write.tmp');
 392     print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
 393 }
 394
 395 {   # test 16: multiple use of a variable in same line with ^<
 396     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
 397     format OUT16 =
 398 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
 399 $txt,             $txt
 400 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
 401 $txt,             $txt
 402 .
 403     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 404     write(OUT16);
 405     close OUT16 or die "Could not close: $!";
 406     my $res = cat('Op_write.tmp');
 407     print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
 408 this_is_block_1   this_is_block_2
 409 this_is_block_3   this_is_block_4
 410 EOD
 411 }
 412
 413 {   # test 17: @* "should be on a line of its own", but it should work
 414     # cleanly with literals before and after. (WL)
 415
 416     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
 417     format OUT17 =
 418 Here we go: @* That's all, folks!
 419             $txt
 420 .
 421     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 422     write(OUT17);
 423     close OUT17 or die "Could not close: $!";
 424     my $res = cat('Op_write.tmp');
 425     chomp( $txt );
 426     my $exp = <<EOD;
 427 Here we go: $txt That's all, folks!
 428 EOD
 429     print $res eq $exp ? "ok 17\n" : "not ok 17\n";
 430 }
 431
 432 {   # test 18: @# and ~~ would cause runaway format, but we now
 433     # catch this while compiling (WL)
 434
 435     format OUT18 =
 436 @######## ~~
 437 10
 438 .
 439     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 440     eval { write(OUT18); };
 441     print +($@ && $@ =~ /Repeated format line will never terminate/)
 442       ? "ok 18\n" : "not ok 18: $@\n";
 443     close OUT18 or die "Could not close: $!";
 444 }
 445
 446 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
 447     my $v = 'gaga';
 448     eval "format OUT19 = \n" .
 449          '@<<<' . "\0\n" .
 450          '$v' .   "\n" .
 451          '@<<<' . "\0\n" .
 452          '$v' . "\n.\n";
 453     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 454     write(OUT19);
 455     close OUT19 or die "Could not close: $!";
 456     my $res = cat('Op_write.tmp');
 457     print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
 458 gaga\0
 459 gaga\0
 460 EOD
 461 }
 462
 463 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
 464     my %h = ( xkey => 'xval', ykey => 'yval' );
 465     format OUT20 =
 466 @>>>> @<<<< ~~
 467 each %h
 468 @>>>> @<<<<
 469 $h{xkey}, $h{ykey}
 470 @>>>> @<<<<
 471 { $h{xkey}, $h{ykey}
 472 }
 473 }
 474 .
 475     my $exp = '';
 476     while( my( $k, $v ) = each( %h ) ){
 477         $exp .= sprintf( "%5s %s\n", $k, $v );
 478     }
 479     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
 480     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
 481     $exp .= "}\n";
 482     open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 483     write(OUT20);
 484     close OUT20 or die "Could not close: $!";
 485     my $res = cat('Op_write.tmp');
 486     print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
 487 }
 488
 489
 490 #####################
 491 ## Section 2
 492 ## numeric formatting
 493 #####################
 494
 495 my $nt = $bas_tests;
 496 for my $tref ( @NumTests ){
 497     my $writefmt = shift( @$tref );
 498     while (@$tref) {
 499         my $val      = shift @$tref;
 500         my $expected = shift @$tref;
 501         my $writeres = swrite( $writefmt, $val );
 502         $nt++;
 503         my $ok = ref($expected)
 504                  ? $writeres =~ $expected
 505                  : $writeres eq $expected;
 506
 507         print $ok
 508             ? "ok $nt - $writefmt\n"
 509             : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
 510     }
 511 }
 512
 513
 514 #####################################
 515 ## Section 3
 516 ## Easiest to add new tests just here
 517 #######################################
 518
 519 curr_test($bas_tests + $num_tests + 1);
 520
 521 use strict;     # Amazed that this hackery can be made strict ...
 522
 523 # DAPM. Exercise a couple of error codepaths
 524
 525 {
 526     local $~ = '';
 527     eval { write };
 528     like $@, qr/Not a format reference/, 'format reference';
 529
 530     $~ = "NOSUCHFORMAT";
 531     eval { write };
 532     like $@, qr/Undefined format/, 'no such format';
 533 }
 534
 535
 536 format EMPTY =
 537 .
 538
 539 my $test = curr_test();
 540
 541 format Comment =
 542 ok @<<<<<
 543 $test
 544 .
 545
 546
 547 # [ID 20020227.005] format bug with undefined _TOP
 548
 549 open STDOUT_DUP, ">&STDOUT";
 550 my $oldfh = select STDOUT_DUP;
 551 $= = 10;
 552 {
 553   local $~ = "Comment";
 554   write;
 555   curr_test($test + 1);
 556   {
 557     local $::TODO = '[ID 20020227.005] format bug with undefined _TOP';
 558     is $-, 9;
 559   }
 560   is $^, "STDOUT_DUP_TOP";
 561 }
 562 select $oldfh;
 563 close STDOUT_DUP;
 564
 565 # scary format testing from H.Merijn Brand
 566
 567 # Just a complete test for format, including top-, left- and bottom marging
 568 # and format detection through glob entries
 569
 570 if (1 || $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
 571     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
 572   $test = curr_test();
 573  SKIP: {
 574       skip "'|-' and '-|' not supported", $tests - $test + 1;
 575   }
 576   exit(0);
 577 }
 578
 579
 580 $^  = "STDOUT_TOP";
 581 $=  =  7;               # Page length
 582 $-  =  0;               # Lines left
 583 my $ps = $^L; $^L = ""; # Catch the page separator
 584 my $tm =  1;            # Top margin (empty lines before first output)
 585 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 586 my $lm =  4;            # Left margin (indent in spaces)
 587
 588 # -----------------------------------------------------------------------
 589 #
 590 # execute the rest of the script in a child process. The parent reads the
 591 # output from the child and compares it with <DATA>.
 592
 593 my @data = <DATA>;
 594
 595 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
 596
 597 my $opened = open FROM_CHILD, "-|";
 598 unless (defined $opened) {
 599     fail "open gave $!";
 600     exit 0;
 601 }
 602
 603 if ($opened) {
 604     # in parent here
 605
 606     pass 'open';
 607     my $s = " " x $lm;
 608     while (<FROM_CHILD>) {
 609         unless (@data) {
 610             fail 'too much output';
 611             exit;
 612         }
 613         s/^/$s/;
 614         my $exp = shift @data;
 615         is $_, $exp;
 616     }
 617     close FROM_CHILD;
 618     is "@data", "", "correct length of output";
 619     exit;
 620 }
 621
 622 # in child here
 623 $::NO_ENDING = 1;
 624
 625     select ((select (STDOUT), $| = 1)[0]);
 626 $tm = "\n" x $tm;
 627 $= -= $bm + 1; # count one for the trailing "----"
 628 my $lastmin = 0;
 629
 630 my @E;
 631
 632 sub wryte
 633 {
 634     $lastmin = $-;
 635     write;
 636     } # wryte;
 637
 638 sub footer
 639 {
 640     $% == 1 and return "";
 641
 642     $lastmin < $= and print "\n" x $lastmin;
 643     print "\n" x $bm, "----\n", $ps;
 644     $lastmin = $-;
 645     "";
 646     } # footer
 647
 648 # Yes, this is sick ;-)
 649 format TOP =
 650 @* ~
 651 @{[footer]}
 652 @* ~
 653 $tm
 654 .
 655
 656 format ENTRY =
 657 @ @<<<<~~
 658 @{(shift @E)||["",""]}
 659 .
 660
 661 format EOR =
 662 - -----
 663 .
 664
 665 sub has_format ($)
 666 {
 667     my $fmt = shift;
 668     exists $::{$fmt} or return 0;
 669     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 670     open my $null, "> /dev/null" or die;
 671     my $fh = select $null;
 672     local $~ = $fmt;
 673     eval "write";
 674     select $fh;
 675     $@?0:1;
 676     } # has_format
 677
 678 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 679 has_format ("ENTRY") or die "No format defined for ENTRY";
 680 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 681                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 682     @E = @$e;
 683     local $~ = "ENTRY";
 684     wryte;
 685     has_format ("EOR") or next;
 686     local $~ = "EOR";
 687     wryte;
 688     }
 689 if (has_format ("EOF")) {
 690     local $~ = "EOF";
 691     wryte;
 692     }
 693
 694 close STDOUT;
 695
 696 # That was test 48.
 697
 698 __END__
 699
 700     1 Test1
 701     2 Test2
 702     3 Test3
 703
 704
 705     ----
 706     \f
 707     4 Test4
 708     5 Test5
 709     6 Test6
 710
 711
 712     ----
 713     \f
 714     7 Test7
 715     - -----
 716
 717
 718
 719     ----
 720     \f
 721     1 1tseT
 722     2 2tseT
 723     3 3tseT
 724
 725
 726     ----
 727     \f
 728     4 4tseT
 729     5 5tseT
 730     - -----