t/op/write.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 print "1..50\n";
   9
  10 my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type'
  11         : ($^O eq 'MacOS') ? 'catenate'
  12         : 'cat';
  13
  14 format OUT =
  15 the quick brown @<<
  16 $fox
  17 jumped
  18 @*
  19 $multiline
  20 ^<<<<<<<<<
  21 $foo
  22 ^<<<<<<<<<
  23 $foo
  24 ^<<<<<<...
  25 $foo
  26 now @<<the@>>>> for all@|||||men to come @<<<<
  27 {
  28     'i' . 's', "time\n", $good, 'to'
  29 }
  30 .
  31
  32 open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
  33 END { 1 while unlink 'Op_write.tmp' }
  34
  35 $fox = 'foxiness';
  36 $good = 'good';
  37 $multiline = "forescore\nand\nseven years\n";
  38 $foo = 'when in the course of human events it becomes necessary';
  39 write(OUT);
  40 close OUT or die "Could not close: $!";
  41
  42 $right =
  43 "the quick brown fox
  44 jumped
  45 forescore
  46 and
  47 seven years
  48 when in
  49 the course
  50 of huma...
  51 now is the time for all good men to come to\n";
  52
  53 if (`$CAT Op_write.tmp` eq $right)
  54     { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
  55 else
  56     { print "not ok 1\n"; }
  57
  58 $fox = 'wolfishness';
  59 my $fox = 'foxiness';           # Test a lexical variable.
  60
  61 format OUT2 =
  62 the quick brown @<<
  63 $fox
  64 jumped
  65 @*
  66 $multiline
  67 ^<<<<<<<<< ~~
  68 $foo
  69 now @<<the@>>>> for all@|||||men to come @<<<<
  70 'i' . 's', "time\n", $good, 'to'
  71 .
  72
  73 open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
  74
  75 $good = 'good';
  76 $multiline = "forescore\nand\nseven years\n";
  77 $foo = 'when in the course of human events it becomes necessary';
  78 write(OUT2);
  79 close OUT2 or die "Could not close: $!";
  80
  81 $right =
  82 "the quick brown fox
  83 jumped
  84 forescore
  85 and
  86 seven years
  87 when in
  88 the course
  89 of human
  90 events it
  91 becomes
  92 necessary
  93 now is the time for all good men to come to\n";
  94
  95 if (`$CAT Op_write.tmp` eq $right)
  96     { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
  97 else
  98     { print "not ok 2\n"; }
  99
 100 eval <<'EOFORMAT';
 101 format OUT2 =
 102 the brown quick @<<
 103 $fox
 104 jumped
 105 @*
 106 $multiline
 107 and
 108 ^<<<<<<<<< ~~
 109 $foo
 110 now @<<the@>>>> for all@|||||men to come @<<<<
 111 'i' . 's', "time\n", $good, 'to'
 112 .
 113 EOFORMAT
 114
 115 open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 116
 117 $fox = 'foxiness';
 118 $good = 'good';
 119 $multiline = "forescore\nand\nseven years\n";
 120 $foo = 'when in the course of human events it becomes necessary';
 121 write(OUT2);
 122 close OUT2 or die "Could not close: $!";
 123
 124 $right =
 125 "the brown quick fox
 126 jumped
 127 forescore
 128 and
 129 seven years
 130 and
 131 when in
 132 the course
 133 of human
 134 events it
 135 becomes
 136 necessary
 137 now is the time for all good men to come to\n";
 138
 139 if (`$CAT Op_write.tmp` eq $right)
 140     { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
 141 else
 142     { print "not ok 3\n"; }
 143
 144 # formline tests
 145
 146 $mustbe = <<EOT;
 147 @ a
 148 @> ab
 149 @>> abc
 150 @>>>  abc
 151 @>>>>   abc
 152 @>>>>>    abc
 153 @>>>>>>     abc
 154 @>>>>>>>      abc
 155 @>>>>>>>>       abc
 156 @>>>>>>>>>        abc
 157 @>>>>>>>>>>         abc
 158 EOT
 159
 160 $was1 = $was2 = '';
 161 for (0..10) {
 162   # lexical picture
 163   $^A = '';
 164   my $format1 = '@' . '>' x $_;
 165   formline $format1, 'abc';
 166   $was1 .= "$format1 $^A\n";
 167   # global
 168   $^A = '';
 169   local $format2 = '@' . '>' x $_;
 170   formline $format2, 'abc';
 171   $was2 .= "$format2 $^A\n";
 172 }
 173 print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
 174 print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
 175
 176 $^A = '';
 177
 178 # more test
 179
 180 format OUT3 =
 181 ^<<<<<<...
 182 $foo
 183 .
 184
 185 open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 186
 187 $foo = 'fit          ';
 188 write(OUT3);
 189 close OUT3 or die "Could not close: $!";
 190
 191 $right =
 192 "fit\n";
 193
 194 if (`$CAT Op_write.tmp` eq $right)
 195     { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
 196 else
 197     { print "not ok 6\n"; }
 198
 199 # test lexicals and globals
 200 {
 201     my $this = "ok";
 202     our $that = 7;
 203     format LEX =
 204 @<<@|
 205 $this,$that
 206 .
 207     open(LEX, ">&STDOUT") or die;
 208     write LEX;
 209     $that = 8;
 210     write LEX;
 211     close LEX or die "Could not close: $!";
 212 }
 213 # LEX_INTERPNORMAL test
 214 my %e = ( a => 1 );
 215 format OUT4 =
 216 @<<<<<<
 217 "$e{a}"
 218 .
 219 open   OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
 220 write (OUT4);
 221 close  OUT4 or die "Could not close: $!";
 222 if (`$CAT Op_write.tmp` eq "1\n") {
 223     print "ok 9\n";
 224     1 while unlink "Op_write.tmp";
 225     }
 226 else {
 227     print "not ok 9\n";
 228     }
 229
 230 eval <<'EOFORMAT';
 231 format OUT10 =
 232 @####.## @0###.##
 233 $test1, $test1
 234 .
 235 EOFORMAT
 236
 237 open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 238
 239 $test1 = 12.95;
 240 write(OUT10);
 241 close OUT10 or die "Could not close: $!";
 242
 243 $right = "   12.95 00012.95\n";
 244 if (`$CAT Op_write.tmp` eq $right)
 245     { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
 246 else
 247     { print "not ok 10\n"; }
 248
 249 eval <<'EOFORMAT';
 250 format OUT11 =
 251 @0###.##
 252 $test1
 253 @ 0#
 254 $test1
 255 @0 #
 256 $test1
 257 .
 258 EOFORMAT
 259
 260 open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 261
 262 $test1 = 12.95;
 263 write(OUT11);
 264 close OUT11 or die "Could not close: $!";
 265
 266 $right =
 267 "00012.95
 268 1 0#
 269 10 #\n";
 270 if (`$CAT Op_write.tmp` eq $right)
 271     { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
 272 else
 273     { print "not ok 11\n"; }
 274
 275 {
 276     my $el;
 277     format STDOUT =
 278 ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
 279 $el
 280 .
 281     my %hash = (12 => 3);
 282     for $el (keys %hash) {
 283         write;
 284     }
 285 }
 286
 287 {
 288     # Bug report and testcase by Alexey Tourbin
 289     use Tie::Scalar;
 290     my $v;
 291     tie $v, 'Tie::StdScalar';
 292     $v = 13;
 293     format OUT13 =
 294 ok ^<<<<<<<<< ~~
 295 $v
 296 .
 297     open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 298     write(OUT13);
 299     close OUT13 or die "Could not close: $!";
 300     print `$CAT Op_write.tmp`;
 301 }
 302
 303 {
 304     # Bug #24774 format without trailing \n failed assertion
 305     my @v = ('k');
 306     eval "format OUT14 = \n@\n\@v";
 307     open(OUT14, '>Op_write.tmp') || die "Can't create Op_write.tmp";
 308     write(OUT14);
 309     close OUT14 or die "Could not close: $!";
 310     print "ok 14\n";
 311 }
 312
 313 #######################################
 314 # Easiest to add new tests above here #
 315 #######################################
 316
 317 # 15..50: scary format testing from Merijn H. Brand
 318
 319 my $test = 15;
 320 my $tests = 50;
 321
 322 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
 323     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
 324   foreach ($test..$tests) {
 325       print "ok $_ # skipped: '|-' and '-|' not supported\n";
 326   }
 327   exit(0);
 328 }
 329
 330
 331 use strict;     # Amazed that this hackery can be made strict ...
 332
 333 # Just a complete test for format, including top-, left- and bottom marging
 334 # and format detection through glob entries
 335
 336 format EMPTY =
 337 .
 338
 339 format Comment =
 340 ok @<<<<<
 341 $test
 342 .
 343
 344 $= = 10;
 345
 346 # [ID 20020227.005] format bug with undefined _TOP
 347 {   local $~ = "Comment";
 348     write;
 349     $test++;
 350     print $- == 9
 351         ? "ok $test\n" : "not ok $test # TODO \$- = $- instead of 9\n";
 352     $test++;
 353     print $^ ne "Comment_TOP"
 354         ? "ok $test\n" : "not ok $test # TODO \$^ = $^ instead of 'STDOUT_TOP'\n";
 355     $test++;
 356     }
 357
 358    $^  = "STDOUT_TOP";
 359    $=  =  7;            # Page length
 360    $-  =  0;            # Lines left
 361 my $ps = $^L; $^L = ""; # Catch the page separator
 362 my $tm =  1;            # Top margin (empty lines before first output)
 363 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 364 my $lm =  4;            # Left margin (indent in spaces)
 365
 366 select ((select (STDOUT), $| = 1)[0]);
 367 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
 368     select ((select (STDOUT), $| = 1)[0]);
 369     my $s = " " x $lm;
 370     while (<STDIN>) {
 371         s/^/$s/;
 372         print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
 373         }
 374     close STDIN;
 375     print + (<DATA>?"not ":""), "ok ", $test++, "\n";
 376     close STDOUT;
 377     exit;
 378     }
 379 $tm = "\n" x $tm;
 380 $= -= $bm + 1; # count one for the trailing "----"
 381 my $lastmin = 0;
 382
 383 my @E;
 384
 385 sub wryte
 386 {
 387     $lastmin = $-;
 388     write;
 389     } # wryte;
 390
 391 sub footer
 392 {
 393     $% == 1 and return "";
 394
 395     $lastmin < $= and print "\n" x $lastmin;
 396     print "\n" x $bm, "----\n", $ps;
 397     $lastmin = $-;
 398     "";
 399     } # footer
 400
 401 # Yes, this is sick ;-)
 402 format TOP =
 403 @* ~
 404 @{[footer]}
 405 @* ~
 406 $tm
 407 .
 408
 409 format ENTRY =
 410 @ @<<<<~~
 411 @{(shift @E)||["",""]}
 412 .
 413
 414 format EOR =
 415 - -----
 416 .
 417
 418 sub has_format ($)
 419 {
 420     my $fmt = shift;
 421     exists $::{$fmt} or return 0;
 422     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 423     open my $null, "> /dev/null" or die;
 424     my $fh = select $null;
 425     local $~ = $fmt;
 426     eval "write";
 427     select $fh;
 428     $@?0:1;
 429     } # has_format
 430
 431 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 432 has_format ("ENTRY") or die "No format defined for ENTRY";
 433 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 434                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 435     @E = @$e;
 436     local $~ = "ENTRY";
 437     wryte;
 438     has_format ("EOR") or next;
 439     local $~ = "EOR";
 440     wryte;
 441     }
 442 if (has_format ("EOF")) {
 443     local $~ = "EOF";
 444     wryte;
 445     }
 446
 447 close STDOUT;
 448
 449 # That was test 48.
 450
 451 __END__
 452
 453     1 Test1
 454     2 Test2
 455     3 Test3
 456
 457
 458     ----
 459     \f
 460     4 Test4
 461     5 Test5
 462     6 Test6
 463
 464
 465     ----
 466     \f
 467     7 Test7
 468     - -----
 469
 470
 471
 472     ----
 473     \f
 474     1 1tseT
 475     2 2tseT
 476     3 3tseT
 477
 478
 479     ----
 480     \f
 481     4 4tseT
 482     5 5tseT
 483     - -----