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