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 +($@ && $@ =~ /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 # Just a complete test for format, including top-, left- and bottom marging
 530 # and format detection through glob entries
 531
 532 format EMPTY =
 533 .
 534
 535 format Comment =
 536 ok @<<<<<
 537 $test
 538 .
 539
 540
 541 # [ID 20020227.005] format bug with undefined _TOP
 542
 543 open STDOUT_DUP, ">&STDOUT";
 544 my $oldfh = select STDOUT_DUP;
 545 $= = 10;
 546 {   local $~ = "Comment";
 547     write;
 548     $test++;
 549     print $- == 9
 550         ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
 551     $test++;
 552     print $^ eq "STDOUT_DUP_TOP"
 553         ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
 554     $test++;
 555 }
 556 select $oldfh;
 557 close STDOUT_DUP;
 558
 559 $^  = "STDOUT_TOP";
 560 $=  =  7;               # Page length
 561 $-  =  0;               # Lines left
 562 my $ps = $^L; $^L = ""; # Catch the page separator
 563 my $tm =  1;            # Top margin (empty lines before first output)
 564 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 565 my $lm =  4;            # Left margin (indent in spaces)
 566
 567 # -----------------------------------------------------------------------
 568 #
 569 # execute the rest of the script in a child process. The parent reads the
 570 # output from the child and compares it with <DATA>.
 571
 572 my @data = <DATA>;
 573
 574 select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
 575
 576 my $opened = open FROM_CHILD, "-|";
 577 unless (defined $opened) {
 578     print "not ok $test - open gave $!\n"; exit 0;
 579 }
 580
 581 if ($opened) {
 582     # in parent here
 583
 584     print "ok $test - open\n"; $test++;
 585     my $s = " " x $lm;
 586     while (<FROM_CHILD>) {
 587         unless (@data) {
 588             print "not ok $test - too much output\n";
 589             exit;
 590         }
 591         s/^/$s/;
 592         my $exp = shift @data;
 593         print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n";
 594         if ($_ ne $exp) {
 595             s/\n/\\n/g for $_, $exp;
 596             print "#expected: $exp\n#got:      $_\n";
 597         }
 598     }
 599     close FROM_CHILD;
 600     print + (@data?"not ":""), "ok ", $test++, " - too litle output\n";
 601     exit;
 602 }
 603
 604 # in child here
 605
 606     select ((select (STDOUT), $| = 1)[0]);
 607 $tm = "\n" x $tm;
 608 $= -= $bm + 1; # count one for the trailing "----"
 609 my $lastmin = 0;
 610
 611 my @E;
 612
 613 sub wryte
 614 {
 615     $lastmin = $-;
 616     write;
 617     } # wryte;
 618
 619 sub footer
 620 {
 621     $% == 1 and return "";
 622
 623     $lastmin < $= and print "\n" x $lastmin;
 624     print "\n" x $bm, "----\n", $ps;
 625     $lastmin = $-;
 626     "";
 627     } # footer
 628
 629 # Yes, this is sick ;-)
 630 format TOP =
 631 @* ~
 632 @{[footer]}
 633 @* ~
 634 $tm
 635 .
 636
 637 format ENTRY =
 638 @ @<<<<~~
 639 @{(shift @E)||["",""]}
 640 .
 641
 642 format EOR =
 643 - -----
 644 .
 645
 646 sub has_format ($)
 647 {
 648     my $fmt = shift;
 649     exists $::{$fmt} or return 0;
 650     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 651     open my $null, "> /dev/null" or die;
 652     my $fh = select $null;
 653     local $~ = $fmt;
 654     eval "write";
 655     select $fh;
 656     $@?0:1;
 657     } # has_format
 658
 659 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 660 has_format ("ENTRY") or die "No format defined for ENTRY";
 661 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 662                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 663     @E = @$e;
 664     local $~ = "ENTRY";
 665     wryte;
 666     has_format ("EOR") or next;
 667     local $~ = "EOR";
 668     wryte;
 669     }
 670 if (has_format ("EOF")) {
 671     local $~ = "EOF";
 672     wryte;
 673     }
 674
 675 close STDOUT;
 676
 677 # That was test 48.
 678
 679 __END__
 680
 681     1 Test1
 682     2 Test2
 683     3 Test3
 684
 685
 686     ----
 687     \f
 688     4 Test4
 689     5 Test5
 690     6 Test6
 691
 692
 693     ----
 694     \f
 695     7 Test7
 696     - -----
 697
 698
 699
 700     ----
 701     \f
 702     1 1tseT
 703     2 2tseT
 704     3 3tseT
 705
 706
 707     ----
 708     \f
 709     4 4tseT
 710     5 5tseT
 711     - -----