t/op/write.t

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