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 $= = 10;
 535
 536 # [ID 20020227.005] format bug with undefined _TOP
 537 {   local $~ = "Comment";
 538     write;
 539     $test++;
 540     print $- == 9
 541         ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
 542     $test++;
 543     print $^ ne "Comment_TOP"
 544         ? "ok $test\n" : "not ok $test # TODO \$^ = $^ instead of 'STDOUT_TOP'\n";
 545     $test++;
 546     }
 547
 548    $^  = "STDOUT_TOP";
 549    $=  =  7;            # Page length
 550    $-  =  0;            # Lines left
 551 my $ps = $^L; $^L = ""; # Catch the page separator
 552 my $tm =  1;            # Top margin (empty lines before first output)
 553 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 554 my $lm =  4;            # Left margin (indent in spaces)
 555
 556 select ((select (STDOUT), $| = 1)[0]);
 557 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
 558     select ((select (STDOUT), $| = 1)[0]);
 559     my $s = " " x $lm;
 560     while (<STDIN>) {
 561         s/^/$s/;
 562         print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
 563         }
 564     close STDIN;
 565     print + (<DATA>?"not ":""), "ok ", $test++, "\n";
 566     close STDOUT;
 567     exit;
 568     }
 569 $tm = "\n" x $tm;
 570 $= -= $bm + 1; # count one for the trailing "----"
 571 my $lastmin = 0;
 572
 573 my @E;
 574
 575 sub wryte
 576 {
 577     $lastmin = $-;
 578     write;
 579     } # wryte;
 580
 581 sub footer
 582 {
 583     $% == 1 and return "";
 584
 585     $lastmin < $= and print "\n" x $lastmin;
 586     print "\n" x $bm, "----\n", $ps;
 587     $lastmin = $-;
 588     "";
 589     } # footer
 590
 591 # Yes, this is sick ;-)
 592 format TOP =
 593 @* ~
 594 @{[footer]}
 595 @* ~
 596 $tm
 597 .
 598
 599 format ENTRY =
 600 @ @<<<<~~
 601 @{(shift @E)||["",""]}
 602 .
 603
 604 format EOR =
 605 - -----
 606 .
 607
 608 sub has_format ($)
 609 {
 610     my $fmt = shift;
 611     exists $::{$fmt} or return 0;
 612     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 613     open my $null, "> /dev/null" or die;
 614     my $fh = select $null;
 615     local $~ = $fmt;
 616     eval "write";
 617     select $fh;
 618     $@?0:1;
 619     } # has_format
 620
 621 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 622 has_format ("ENTRY") or die "No format defined for ENTRY";
 623 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 624                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 625     @E = @$e;
 626     local $~ = "ENTRY";
 627     wryte;
 628     has_format ("EOR") or next;
 629     local $~ = "EOR";
 630     wryte;
 631     }
 632 if (has_format ("EOF")) {
 633     local $~ = "EOF";
 634     wryte;
 635     }
 636
 637 close STDOUT;
 638
 639 # That was test 48.
 640
 641 __END__
 642
 643     1 Test1
 644     2 Test2
 645     3 Test3
 646
 647
 648     ----
 649     \f
 650     4 Test4
 651     5 Test5
 652     6 Test6
 653
 654
 655     ----
 656     \f
 657     7 Test7
 658     - -----
 659
 660
 661
 662     ----
 663     \f
 664     1 1tseT
 665     2 2tseT
 666     3 3tseT
 667
 668
 669     ----
 670     \f
 671     4 4tseT
 672     5 5tseT
 673     - -----