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