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 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 # Easiest to add new tests above here #
 305 #######################################
 306
 307 # 14..49: scary format testing from Merijn H. Brand
 308
 309 my $test = 14;
 310 my $tests = 49;
 311
 312 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
 313     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
 314   foreach ($test..$tests) {
 315       print "ok $_ # skipped: '|-' and '-|' not supported\n";
 316   }
 317   exit(0);
 318 }
 319
 320
 321 use strict;     # Amazed that this hackery can be made strict ...
 322
 323 # Just a complete test for format, including top-, left- and bottom marging
 324 # and format detection through glob entries
 325
 326 format EMPTY =
 327 .
 328
 329 format Comment =
 330 ok @<<<<<
 331 $test
 332 .
 333
 334 $= = 10;
 335
 336 # [ID 20020227.005] format bug with undefined _TOP
 337 {   local $~ = "Comment";
 338     write;
 339     $test++;
 340     print $- == 9
 341         ? "ok $test\n" : "not ok $test # TODO \$- = $- instead of 9\n";
 342     $test++;
 343     print $^ ne "Comment_TOP"
 344         ? "ok $test\n" : "not ok $test # TODO \$^ = $^ instead of 'STDOUT_TOP'\n";
 345     $test++;
 346     }
 347
 348    $^  = "STDOUT_TOP";
 349    $=  =  7;            # Page length
 350    $-  =  0;            # Lines left
 351 my $ps = $^L; $^L = ""; # Catch the page separator
 352 my $tm =  1;            # Top margin (empty lines before first output)
 353 my $bm =  2;            # Bottom marging (empty lines between last text and footer)
 354 my $lm =  4;            # Left margin (indent in spaces)
 355
 356 select ((select (STDOUT), $| = 1)[0]);
 357 if ($lm > 0 and !open STDOUT, "|-") {   # Left margin (in this test ALWAYS set)
 358     select ((select (STDOUT), $| = 1)[0]);
 359     my $s = " " x $lm;
 360     while (<STDIN>) {
 361         s/^/$s/;
 362         print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
 363         }
 364     close STDIN;
 365     print + (<DATA>?"not ":""), "ok ", $test++, "\n";
 366     close STDOUT;
 367     exit;
 368     }
 369 $tm = "\n" x $tm;
 370 $= -= $bm + 1; # count one for the trailing "----"
 371 my $lastmin = 0;
 372
 373 my @E;
 374
 375 sub wryte
 376 {
 377     $lastmin = $-;
 378     write;
 379     } # wryte;
 380
 381 sub footer
 382 {
 383     $% == 1 and return "";
 384
 385     $lastmin < $= and print "\n" x $lastmin;
 386     print "\n" x $bm, "----\n", $ps;
 387     $lastmin = $-;
 388     "";
 389     } # footer
 390
 391 # Yes, this is sick ;-)
 392 format TOP =
 393 @* ~
 394 @{[footer]}
 395 @* ~
 396 $tm
 397 .
 398
 399 format ENTRY =
 400 @ @<<<<~~
 401 @{(shift @E)||["",""]}
 402 .
 403
 404 format EOR =
 405 - -----
 406 .
 407
 408 sub has_format ($)
 409 {
 410     my $fmt = shift;
 411     exists $::{$fmt} or return 0;
 412     $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
 413     open my $null, "> /dev/null" or die;
 414     my $fh = select $null;
 415     local $~ = $fmt;
 416     eval "write";
 417     select $fh;
 418     $@?0:1;
 419     } # has_format
 420
 421 $^ = has_format ("TOP") ? "TOP" : "EMPTY";
 422 has_format ("ENTRY") or die "No format defined for ENTRY";
 423 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 424                 [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
 425     @E = @$e;
 426     local $~ = "ENTRY";
 427     wryte;
 428     has_format ("EOR") or next;
 429     local $~ = "EOR";
 430     wryte;
 431     }
 432 if (has_format ("EOF")) {
 433     local $~ = "EOF";
 434     wryte;
 435     }
 436
 437 close STDOUT;
 438
 439 # That was test 48.
 440
 441 __END__
 442
 443     1 Test1
 444     2 Test2
 445     3 Test3
 446
 447
 448     ----
 449     \f
 450     4 Test4
 451     5 Test5
 452     6 Test6
 453
 454
 455     ----
 456     \f
 457     7 Test7
 458     - -----
 459
 460
 461
 462     ----
 463     \f
 464     1 1tseT
 465     2 2tseT
 466     3 3tseT
 467
 468
 469     ----
 470     \f
 471     4 4tseT
 472     5 5tseT
 473     - -----