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