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 = 37;
  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 $@ ? "ok 14\n" : "not ok 14\n";
 369
 370 }
 371
 372 {   # test 15
 373     # text lost in ^<<< field with \r in value (WL)
 374     my $txt = "line 1\rline 2";
 375     format OUT15 =
 376 ^<<<<<<<<<<<<<<<<<<
 377 $txt
 378 ^<<<<<<<<<<<<<<<<<<
 379 $txt
 380 .
 381     open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 382     write(OUT15);
 383     close OUT15 or die "Could not close: $!";
 384     my $res = cat('Op_write.tmp');
 385     print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
 386 }
 387
 388 {   # test 16: multiple use of a variable in same line with ^<
 389     my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
 390     format OUT16 =
 391 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
 392 $txt,             $txt
 393 ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
 394 $txt,             $txt
 395 .
 396     open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 397     write(OUT16);
 398     close OUT16 or die "Could not close: $!";
 399     my $res = cat('Op_write.tmp');
 400     print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
 401 this_is_block_1   this_is_block_2
 402 this_is_block_3   this_is_block_4
 403 EOD
 404 }
 405
 406 {   # test 17: @* "should be on a line of its own", but it should work
 407     # cleanly with literals before and after. (WL)
 408
 409     my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
 410     format OUT17 =
 411 Here we go: @* That's all, folks!
 412             $txt
 413 .
 414     open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 415     write(OUT17);
 416     close OUT17 or die "Could not close: $!";
 417     my $res = cat('Op_write.tmp');
 418     chomp( $txt );
 419     my $exp = <<EOD;
 420 Here we go: $txt That's all, folks!
 421 EOD
 422     print $res eq $exp ? "ok 17\n" : "not ok 17\n";
 423 }
 424
 425 {   # test 18: @# and ~~ would cause runaway format, but we now
 426     # catch this while compiling (WL)
 427
 428     format OUT18 =
 429 @######## ~~
 430 10
 431 .
 432     open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 433     eval { write(OUT18); };
 434     print $@ ? "ok 18\n" : "not ok 18\n";
 435     close OUT18 or die "Could not close: $!";
 436 }
 437
 438 {   # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
 439     my $v = 'gaga';
 440     eval "format OUT19 = \n" .
 441          '@<<<' . "\0\n" .
 442          '$v' .   "\n" .
 443          '@<<<' . "\0\n" .
 444          '$v' . "\n.\n";
 445     open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 446     write(OUT19);
 447     close OUT19 or die "Could not close: $!";
 448     my $res = cat('Op_write.tmp');
 449     print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
 450 gaga\0
 451 gaga\0
 452 EOD
 453 }
 454
 455 {   # test 20: hash accesses; single '}' must not terminate format '}' (WL)
 456     my %h = ( xkey => 'xval', ykey => 'yval' );
 457     format OUT20 =
 458 @>>>> @<<<< ~~
 459 each %h
 460 @>>>> @<<<<
 461 $h{xkey}, $h{ykey}
 462 @>>>> @<<<<
 463 { $h{xkey}, $h{ykey}
 464 }
 465 }
 466 .
 467     my $exp = '';
 468     while( my( $k, $v ) = each( %h ) ){
 469         $exp .= sprintf( "%5s %s\n", $k, $v );
 470     }
 471     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
 472     $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
 473     $exp .= "}\n";
 474     open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 475     write(OUT20);
 476     close OUT20 or die "Could not close: $!";
 477     my $res = cat('Op_write.tmp');
 478     print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
 479 }
 480
 481
 482 #####################
 483 ## Section 2
 484 ## numeric formatting
 485 #####################
 486
 487 my $nt = $bas_tests;
 488 for my $tref ( @NumTests ){
 489     my $writefmt = shift( @$tref );
 490     while (@$tref) {
 491         my $val      = shift @$tref;
 492         my $expected = shift @$tref;
 493         my $writeres = swrite( $writefmt, $val );
 494         $nt++;
 495         my $ok = ref($expected)
 496                  ? $writeres =~ $expected
 497                  : $writeres eq $expected;
 498
 499         print $ok
 500             ? "ok $nt - $writefmt\n"
 501             : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
 502     }
 503 }
 504
 505
 506 #####################################
 507 ## Section 3
 508 ## Easiest to add new tests above here
 509 #######################################
 510
 511 # scary format testing from H.Merijn Brand
 512
 513 my $test = $bas_tests + $num_tests + 1;
 514 my $tests = $bas_tests + $num_tests + $hmb_tests;
 515
 516 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
 517     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
 518   foreach ($test..$tests) {
 519       print "ok $_ # skipped: '|-' and '-|' not supported\n";
 520   }
 521   exit(0);
 522 }
 523
 524
 525 use strict;     # Amazed that this hackery can be made strict ...
 526
 527 # Just a complete test for format, including top-, left- and bottom marging
 528 # and format detection through glob entries
 529
 530 format EMPTY =
 531 .
 532
 533 format Comment =
 534 ok @<<<<<
 535 $test
 536 .
 537
 538
 539 # [ID 20020227.005] format bug with undefined _TOP
 540
 541 open STDOUT_DUP, ">&STDOUT";
 542 my $oldfh = select STDOUT_DUP;
 543 $= = 10;
 544 {   local $~ = "Comment";
 545     write;
 546     $test++;
 547     print $- == 9
 548         ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
 549     $test++;
 550     print $^ eq "STDOUT_DUP_TOP"
 551         ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
 552     $test++;
 553 }
 554 select $oldfh;
 555 close STDOUT_DUP;
 556
 557 $^  = "STDOUT_TOP";
 558 $=  =  7;               # Page length
 559 $-  =  0;               # Lines left
 560 my $ps = $^L; $^L = ""; # Catch the page separator
 561 my $tm =  1;            # Top margin (empty lines before first output)
 562 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 563 my $lm =  4;            # Left margin (indent in spaces)
 564
 565 # -----------------------------------------------------------------------
 566 #
 567 # execute the rest of the script in a child process. The parent reads the
 568 # output from the child and compares it with <DATA>.
 569
 570 my @data = <DATA>;
 571
 572 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
 573
 574 my $opened = open FROM_CHILD, "-|";
 575 unless (defined $opened) {
 576     print "not ok $test - open gave $!\n"; exit 0;
 577 }
 578
 579 if ($opened) {
 580     # in parent here
 581
 582     print "ok $test - open\n"; $test++;
 583     my $s = " " x $lm;
 584     while (<FROM_CHILD>) {
 585         unless (@data) {
 586             print "not ok $test - too much output\n";
 587             exit;
 588         }
 589         s/^/$s/;
 590         my $exp = shift @data;
 591         print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n";
 592         if ($_ ne $exp) {
 593             s/\n/\\n/g for $_, $exp;
 594             print "#expected: $exp\n#got:      $_\n";
 595         }
 596     }
 597     close FROM_CHILD;
 598     print + (@data?"not ":""), "ok ", $test++, " - too litle output\n";
 599     exit;
 600 }
 601
 602 # in child here
 603
 604     select ((select (STDOUT), $| = 1)[0]);
 605 $tm = "\n" x $tm;
 606 $= -= $bm + 1; # count one for the trailing "----"
 607 my $lastmin = 0;
 608
 609 my @E;
 610
 611 sub wryte
 612 {
 613     $lastmin = $-;
 614     write;
 615     } # wryte;
 616
 617 sub footer
 618 {
 619     $% == 1 and return "";
 620
 621     $lastmin < $= and print "\n" x $lastmin;
 622     print "\n" x $bm, "----\n", $ps;
 623     $lastmin = $-;
 624     "";
 625     } # footer
 626
 627 # Yes, this is sick ;-)
 628 format TOP =
 629 @* ~
 630 @{[footer]}
 631 @* ~
 632 $tm
 633 .
 634
 635 format ENTRY =
 636 @ @<<<<~~
 637 @{(shift @E)||["",""]}
 638 .
 639
 640 format EOR =
 641 - -----
 642 .
 643
 644 sub has_format ($)
 645 {
 646     my $fmt = shift;
 647     exists $::{$fmt} or return 0;
 648     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 649     open my $null, "> /dev/null" or die;
 650     my $fh = select $null;
 651     local $~ = $fmt;
 652     eval "write";
 653     select $fh;
 654     $@?0:1;
 655     } # has_format
 656
 657 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 658 has_format ("ENTRY") or die "No format defined for ENTRY";
 659 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 660                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 661     @E = @$e;
 662     local $~ = "ENTRY";
 663     wryte;
 664     has_format ("EOR") or next;
 665     local $~ = "EOR";
 666     wryte;
 667     }
 668 if (has_format ("EOF")) {
 669     local $~ = "EOF";
 670     wryte;
 671     }
 672
 673 close STDOUT;
 674
 675 # That was test 48.
 676
 677 __END__
 678
 679     1 Test1
 680     2 Test2
 681     3 Test3
 682
 683
 684     ----
 685     \f
 686     4 Test4
 687     5 Test5
 688     6 Test6
 689
 690
 691     ----
 692     \f
 693     7 Test7
 694     - -----
 695
 696
 697
 698     ----
 699     \f
 700     1 1tseT
 701     2 2tseT
 702     3 3tseT
 703
 704
 705     ----
 706     \f
 707     4 4tseT
 708     5 5tseT
 709     - -----