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