t/op/write.t

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