t/op/write.t

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