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.5, '####',
  20                 9999.4999,   '9999',    -999.5, '####',     1e+100, '####' ],
  21
  22     [ '@0##',           0,   '0000',         1, '0001',     9999.5, '####',
  23                 -999.4999,   '-999',    -999.5, '####',     1e+100, '####' ],
  24
  25     [ '^###',           0,   '   0',     undef, '    ' ],
  26
  27     [ '^0##',           0,   '0000',     undef, '    ' ],
  28
  29     [ '@###.',          0,  '   0.',         1, '   1.',    9999.5, '#####',
  30                 9999.4999,  '9999.',    -999.5, '#####' ],
  31
  32     [ '@##.##',         0, '  0.00',         1, '  1.00',  999.995, '######',
  33                 999.99499, '999.99',      -100, '######' ],
  34
  35     [ '@0#.##',         0, '000.00',         1, '001.00',       10, '010.00',
  36                   -0.0001, '-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
 490         print $expected eq $writeres
 491             ? "ok $nt\n"
 492             : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
 493     }
 494 }
 495
 496
 497 #####################################
 498 ## Section 3
 499 ## Easiest to add new tests above here
 500 #######################################
 501
 502 # scary format testing from H.Merijn Brand
 503
 504 my $test = $bas_tests + $num_tests + 1;
 505 my $tests = $bas_tests + $num_tests + $hmb_tests;
 506
 507 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
 508     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
 509   foreach ($test..$tests) {
 510       print "ok $_ # skipped: '|-' and '-|' not supported\n";
 511   }
 512   exit(0);
 513 }
 514
 515
 516 use strict;     # Amazed that this hackery can be made strict ...
 517
 518 # Just a complete test for format, including top-, left- and bottom marging
 519 # and format detection through glob entries
 520
 521 format EMPTY =
 522 .
 523
 524 format Comment =
 525 ok @<<<<<
 526 $test
 527 .
 528
 529
 530 # [ID 20020227.005] format bug with undefined _TOP
 531
 532 open STDOUT_DUP, ">&STDOUT";
 533 my $oldfh = select STDOUT_DUP;
 534 $= = 10;
 535 {   local $~ = "Comment";
 536     write;
 537     $test++;
 538     print $- == 9
 539         ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
 540     $test++;
 541     print $^ eq "STDOUT_DUP_TOP"
 542         ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
 543     $test++;
 544 }
 545 select $oldfh;
 546
 547 $^  = "STDOUT_TOP";
 548 $=  =  7;               # Page length
 549 $-  =  0;               # Lines left
 550 my $ps = $^L; $^L = ""; # Catch the page separator
 551 my $tm =  1;            # Top margin (empty lines before first output)
 552 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 553 my $lm =  4;            # Left margin (indent in spaces)
 554
 555 select ((select (STDOUT), $| = 1)[0]);
 556 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
 557     select ((select (STDOUT), $| = 1)[0]);
 558     my $s = " " x $lm;
 559     while (<STDIN>) {
 560         s/^/$s/;
 561         print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
 562         }
 563     close STDIN;
 564     print + (<DATA>?"not ":""), "ok ", $test++, "\n";
 565     close STDOUT;
 566     exit;
 567     }
 568 $tm = "\n" x $tm;
 569 $= -= $bm + 1; # count one for the trailing "----"
 570 my $lastmin = 0;
 571
 572 my @E;
 573
 574 sub wryte
 575 {
 576     $lastmin = $-;
 577     write;
 578     } # wryte;
 579
 580 sub footer
 581 {
 582     $% == 1 and return "";
 583
 584     $lastmin < $= and print "\n" x $lastmin;
 585     print "\n" x $bm, "----\n", $ps;
 586     $lastmin = $-;
 587     "";
 588     } # footer
 589
 590 # Yes, this is sick ;-)
 591 format TOP =
 592 @* ~
 593 @{[footer]}
 594 @* ~
 595 $tm
 596 .
 597
 598 format ENTRY =
 599 @ @<<<<~~
 600 @{(shift @E)||["",""]}
 601 .
 602
 603 format EOR =
 604 - -----
 605 .
 606
 607 sub has_format ($)
 608 {
 609     my $fmt = shift;
 610     exists $::{$fmt} or return 0;
 611     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 612     open my $null, "> /dev/null" or die;
 613     my $fh = select $null;
 614     local $~ = $fmt;
 615     eval "write";
 616     select $fh;
 617     $@?0:1;
 618     } # has_format
 619
 620 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 621 has_format ("ENTRY") or die "No format defined for ENTRY";
 622 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 623                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 624     @E = @$e;
 625     local $~ = "ENTRY";
 626     wryte;
 627     has_format ("EOR") or next;
 628     local $~ = "EOR";
 629     wryte;
 630     }
 631 if (has_format ("EOF")) {
 632     local $~ = "EOF";
 633     wryte;
 634     }
 635
 636 close STDOUT;
 637
 638 # That was test 48.
 639
 640 __END__
 641
 642     1 Test1
 643     2 Test2
 644     3 Test3
 645
 646
 647     ----
 648     \f
 649     4 Test4
 650     5 Test5
 651     6 Test6
 652
 653
 654     ----
 655     \f
 656     7 Test7
 657     - -----
 658
 659
 660
 661     ----
 662     \f
 663     1 1tseT
 664     2 2tseT
 665     3 3tseT
 666
 667
 668     ----
 669     \f
 670     4 4tseT
 671     5 5tseT
 672     - -----