t/op/write.t

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