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