1*0Sstevel@tonic-gate#!./perl 2*0Sstevel@tonic-gate 3*0Sstevel@tonic-gateBEGIN { 4*0Sstevel@tonic-gate chdir 't' if -d 't'; 5*0Sstevel@tonic-gate @INC = '../lib'; 6*0Sstevel@tonic-gate} 7*0Sstevel@tonic-gate 8*0Sstevel@tonic-gate# read in a file 9*0Sstevel@tonic-gatesub cat { 10*0Sstevel@tonic-gate my $file = shift; 11*0Sstevel@tonic-gate local $/; 12*0Sstevel@tonic-gate open my $fh, $file or die "can't open '$file': $!"; 13*0Sstevel@tonic-gate my $data = <$fh>; 14*0Sstevel@tonic-gate close $fh; 15*0Sstevel@tonic-gate $data; 16*0Sstevel@tonic-gate} 17*0Sstevel@tonic-gate 18*0Sstevel@tonic-gate#-- testing numeric fields in all variants (WL) 19*0Sstevel@tonic-gate 20*0Sstevel@tonic-gatesub swrite { 21*0Sstevel@tonic-gate my $format = shift; 22*0Sstevel@tonic-gate local $^A = ""; # don't litter, use a local bin 23*0Sstevel@tonic-gate formline( $format, @_ ); 24*0Sstevel@tonic-gate return $^A; 25*0Sstevel@tonic-gate} 26*0Sstevel@tonic-gate 27*0Sstevel@tonic-gatemy @NumTests = ( 28*0Sstevel@tonic-gate # [ format, value1, expected1, value2, expected2, .... ] 29*0Sstevel@tonic-gate [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', 30*0Sstevel@tonic-gate 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], 31*0Sstevel@tonic-gate 32*0Sstevel@tonic-gate [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', 33*0Sstevel@tonic-gate -999.4999, '-999', -999.6, '####', 1e+100, '####' ], 34*0Sstevel@tonic-gate 35*0Sstevel@tonic-gate [ '^###', 0, ' 0', undef, ' ' ], 36*0Sstevel@tonic-gate 37*0Sstevel@tonic-gate [ '^0##', 0, '0000', undef, ' ' ], 38*0Sstevel@tonic-gate 39*0Sstevel@tonic-gate [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', 40*0Sstevel@tonic-gate 9999.4999, '9999.', -999.6, '#####' ], 41*0Sstevel@tonic-gate 42*0Sstevel@tonic-gate [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', 43*0Sstevel@tonic-gate 999.99499, '999.99', -100, '######' ], 44*0Sstevel@tonic-gate 45*0Sstevel@tonic-gate [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', 46*0Sstevel@tonic-gate -0.0001, qr/^[\-0]00\.00$/ ], 47*0Sstevel@tonic-gate 48*0Sstevel@tonic-gate); 49*0Sstevel@tonic-gate 50*0Sstevel@tonic-gate 51*0Sstevel@tonic-gatemy $num_tests = 0; 52*0Sstevel@tonic-gatefor my $tref ( @NumTests ){ 53*0Sstevel@tonic-gate $num_tests += (@$tref - 1)/2; 54*0Sstevel@tonic-gate} 55*0Sstevel@tonic-gate#--------------------------------------------------------- 56*0Sstevel@tonic-gate 57*0Sstevel@tonic-gate# number of tests in section 1 58*0Sstevel@tonic-gatemy $bas_tests = 20; 59*0Sstevel@tonic-gate 60*0Sstevel@tonic-gate# number of tests in section 3 61*0Sstevel@tonic-gatemy $hmb_tests = 37; 62*0Sstevel@tonic-gate 63*0Sstevel@tonic-gateprintf "1..%d\n", $bas_tests + $num_tests + $hmb_tests; 64*0Sstevel@tonic-gate 65*0Sstevel@tonic-gate############ 66*0Sstevel@tonic-gate## Section 1 67*0Sstevel@tonic-gate############ 68*0Sstevel@tonic-gate 69*0Sstevel@tonic-gateformat OUT = 70*0Sstevel@tonic-gatethe quick brown @<< 71*0Sstevel@tonic-gate$fox 72*0Sstevel@tonic-gatejumped 73*0Sstevel@tonic-gate@* 74*0Sstevel@tonic-gate$multiline 75*0Sstevel@tonic-gate^<<<<<<<<< 76*0Sstevel@tonic-gate$foo 77*0Sstevel@tonic-gate^<<<<<<<<< 78*0Sstevel@tonic-gate$foo 79*0Sstevel@tonic-gate^<<<<<<... 80*0Sstevel@tonic-gate$foo 81*0Sstevel@tonic-gatenow @<<the@>>>> for all@|||||men to come @<<<< 82*0Sstevel@tonic-gate{ 83*0Sstevel@tonic-gate 'i' . 's', "time\n", $good, 'to' 84*0Sstevel@tonic-gate} 85*0Sstevel@tonic-gate. 86*0Sstevel@tonic-gate 87*0Sstevel@tonic-gateopen(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 88*0Sstevel@tonic-gateEND { 1 while unlink 'Op_write.tmp' } 89*0Sstevel@tonic-gate 90*0Sstevel@tonic-gate$fox = 'foxiness'; 91*0Sstevel@tonic-gate$good = 'good'; 92*0Sstevel@tonic-gate$multiline = "forescore\nand\nseven years\n"; 93*0Sstevel@tonic-gate$foo = 'when in the course of human events it becomes necessary'; 94*0Sstevel@tonic-gatewrite(OUT); 95*0Sstevel@tonic-gateclose OUT or die "Could not close: $!"; 96*0Sstevel@tonic-gate 97*0Sstevel@tonic-gate$right = 98*0Sstevel@tonic-gate"the quick brown fox 99*0Sstevel@tonic-gatejumped 100*0Sstevel@tonic-gateforescore 101*0Sstevel@tonic-gateand 102*0Sstevel@tonic-gateseven years 103*0Sstevel@tonic-gatewhen in 104*0Sstevel@tonic-gatethe course 105*0Sstevel@tonic-gateof huma... 106*0Sstevel@tonic-gatenow is the time for all good men to come to\n"; 107*0Sstevel@tonic-gate 108*0Sstevel@tonic-gateif (cat('Op_write.tmp') eq $right) 109*0Sstevel@tonic-gate { print "ok 1\n"; 1 while unlink 'Op_write.tmp'; } 110*0Sstevel@tonic-gateelse 111*0Sstevel@tonic-gate { print "not ok 1\n"; } 112*0Sstevel@tonic-gate 113*0Sstevel@tonic-gate$fox = 'wolfishness'; 114*0Sstevel@tonic-gatemy $fox = 'foxiness'; # Test a lexical variable. 115*0Sstevel@tonic-gate 116*0Sstevel@tonic-gateformat OUT2 = 117*0Sstevel@tonic-gatethe quick brown @<< 118*0Sstevel@tonic-gate$fox 119*0Sstevel@tonic-gatejumped 120*0Sstevel@tonic-gate@* 121*0Sstevel@tonic-gate$multiline 122*0Sstevel@tonic-gate^<<<<<<<<< ~~ 123*0Sstevel@tonic-gate$foo 124*0Sstevel@tonic-gatenow @<<the@>>>> for all@|||||men to come @<<<< 125*0Sstevel@tonic-gate'i' . 's', "time\n", $good, 'to' 126*0Sstevel@tonic-gate. 127*0Sstevel@tonic-gate 128*0Sstevel@tonic-gateopen OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; 129*0Sstevel@tonic-gate 130*0Sstevel@tonic-gate$good = 'good'; 131*0Sstevel@tonic-gate$multiline = "forescore\nand\nseven years\n"; 132*0Sstevel@tonic-gate$foo = 'when in the course of human events it becomes necessary'; 133*0Sstevel@tonic-gatewrite(OUT2); 134*0Sstevel@tonic-gateclose OUT2 or die "Could not close: $!"; 135*0Sstevel@tonic-gate 136*0Sstevel@tonic-gate$right = 137*0Sstevel@tonic-gate"the quick brown fox 138*0Sstevel@tonic-gatejumped 139*0Sstevel@tonic-gateforescore 140*0Sstevel@tonic-gateand 141*0Sstevel@tonic-gateseven years 142*0Sstevel@tonic-gatewhen in 143*0Sstevel@tonic-gatethe course 144*0Sstevel@tonic-gateof human 145*0Sstevel@tonic-gateevents it 146*0Sstevel@tonic-gatebecomes 147*0Sstevel@tonic-gatenecessary 148*0Sstevel@tonic-gatenow is the time for all good men to come to\n"; 149*0Sstevel@tonic-gate 150*0Sstevel@tonic-gateif (cat('Op_write.tmp') eq $right) 151*0Sstevel@tonic-gate { print "ok 2\n"; 1 while unlink 'Op_write.tmp'; } 152*0Sstevel@tonic-gateelse 153*0Sstevel@tonic-gate { print "not ok 2\n"; } 154*0Sstevel@tonic-gate 155*0Sstevel@tonic-gateeval <<'EOFORMAT'; 156*0Sstevel@tonic-gateformat OUT2 = 157*0Sstevel@tonic-gatethe brown quick @<< 158*0Sstevel@tonic-gate$fox 159*0Sstevel@tonic-gatejumped 160*0Sstevel@tonic-gate@* 161*0Sstevel@tonic-gate$multiline 162*0Sstevel@tonic-gateand 163*0Sstevel@tonic-gate^<<<<<<<<< ~~ 164*0Sstevel@tonic-gate$foo 165*0Sstevel@tonic-gatenow @<<the@>>>> for all@|||||men to come @<<<< 166*0Sstevel@tonic-gate'i' . 's', "time\n", $good, 'to' 167*0Sstevel@tonic-gate. 168*0Sstevel@tonic-gateEOFORMAT 169*0Sstevel@tonic-gate 170*0Sstevel@tonic-gateopen(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 171*0Sstevel@tonic-gate 172*0Sstevel@tonic-gate$fox = 'foxiness'; 173*0Sstevel@tonic-gate$good = 'good'; 174*0Sstevel@tonic-gate$multiline = "forescore\nand\nseven years\n"; 175*0Sstevel@tonic-gate$foo = 'when in the course of human events it becomes necessary'; 176*0Sstevel@tonic-gatewrite(OUT2); 177*0Sstevel@tonic-gateclose OUT2 or die "Could not close: $!"; 178*0Sstevel@tonic-gate 179*0Sstevel@tonic-gate$right = 180*0Sstevel@tonic-gate"the brown quick fox 181*0Sstevel@tonic-gatejumped 182*0Sstevel@tonic-gateforescore 183*0Sstevel@tonic-gateand 184*0Sstevel@tonic-gateseven years 185*0Sstevel@tonic-gateand 186*0Sstevel@tonic-gatewhen in 187*0Sstevel@tonic-gatethe course 188*0Sstevel@tonic-gateof human 189*0Sstevel@tonic-gateevents it 190*0Sstevel@tonic-gatebecomes 191*0Sstevel@tonic-gatenecessary 192*0Sstevel@tonic-gatenow is the time for all good men to come to\n"; 193*0Sstevel@tonic-gate 194*0Sstevel@tonic-gateif (cat('Op_write.tmp') eq $right) 195*0Sstevel@tonic-gate { print "ok 3\n"; 1 while unlink 'Op_write.tmp'; } 196*0Sstevel@tonic-gateelse 197*0Sstevel@tonic-gate { print "not ok 3\n"; } 198*0Sstevel@tonic-gate 199*0Sstevel@tonic-gate# formline tests 200*0Sstevel@tonic-gate 201*0Sstevel@tonic-gate$mustbe = <<EOT; 202*0Sstevel@tonic-gate@ a 203*0Sstevel@tonic-gate@> ab 204*0Sstevel@tonic-gate@>> abc 205*0Sstevel@tonic-gate@>>> abc 206*0Sstevel@tonic-gate@>>>> abc 207*0Sstevel@tonic-gate@>>>>> abc 208*0Sstevel@tonic-gate@>>>>>> abc 209*0Sstevel@tonic-gate@>>>>>>> abc 210*0Sstevel@tonic-gate@>>>>>>>> abc 211*0Sstevel@tonic-gate@>>>>>>>>> abc 212*0Sstevel@tonic-gate@>>>>>>>>>> abc 213*0Sstevel@tonic-gateEOT 214*0Sstevel@tonic-gate 215*0Sstevel@tonic-gate$was1 = $was2 = ''; 216*0Sstevel@tonic-gatefor (0..10) { 217*0Sstevel@tonic-gate # lexical picture 218*0Sstevel@tonic-gate $^A = ''; 219*0Sstevel@tonic-gate my $format1 = '@' . '>' x $_; 220*0Sstevel@tonic-gate formline $format1, 'abc'; 221*0Sstevel@tonic-gate $was1 .= "$format1 $^A\n"; 222*0Sstevel@tonic-gate # global 223*0Sstevel@tonic-gate $^A = ''; 224*0Sstevel@tonic-gate local $format2 = '@' . '>' x $_; 225*0Sstevel@tonic-gate formline $format2, 'abc'; 226*0Sstevel@tonic-gate $was2 .= "$format2 $^A\n"; 227*0Sstevel@tonic-gate} 228*0Sstevel@tonic-gateprint $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; 229*0Sstevel@tonic-gateprint $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; 230*0Sstevel@tonic-gate 231*0Sstevel@tonic-gate$^A = ''; 232*0Sstevel@tonic-gate 233*0Sstevel@tonic-gate# more test 234*0Sstevel@tonic-gate 235*0Sstevel@tonic-gateformat OUT3 = 236*0Sstevel@tonic-gate^<<<<<<... 237*0Sstevel@tonic-gate$foo 238*0Sstevel@tonic-gate. 239*0Sstevel@tonic-gate 240*0Sstevel@tonic-gateopen(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 241*0Sstevel@tonic-gate 242*0Sstevel@tonic-gate$foo = 'fit '; 243*0Sstevel@tonic-gatewrite(OUT3); 244*0Sstevel@tonic-gateclose OUT3 or die "Could not close: $!"; 245*0Sstevel@tonic-gate 246*0Sstevel@tonic-gate$right = 247*0Sstevel@tonic-gate"fit\n"; 248*0Sstevel@tonic-gate 249*0Sstevel@tonic-gateif (cat('Op_write.tmp') eq $right) 250*0Sstevel@tonic-gate { print "ok 6\n"; 1 while unlink 'Op_write.tmp'; } 251*0Sstevel@tonic-gateelse 252*0Sstevel@tonic-gate { print "not ok 6\n"; } 253*0Sstevel@tonic-gate 254*0Sstevel@tonic-gate# test lexicals and globals 255*0Sstevel@tonic-gate{ 256*0Sstevel@tonic-gate my $this = "ok"; 257*0Sstevel@tonic-gate our $that = 7; 258*0Sstevel@tonic-gate format LEX = 259*0Sstevel@tonic-gate@<<@| 260*0Sstevel@tonic-gate$this,$that 261*0Sstevel@tonic-gate. 262*0Sstevel@tonic-gate open(LEX, ">&STDOUT") or die; 263*0Sstevel@tonic-gate write LEX; 264*0Sstevel@tonic-gate $that = 8; 265*0Sstevel@tonic-gate write LEX; 266*0Sstevel@tonic-gate close LEX or die "Could not close: $!"; 267*0Sstevel@tonic-gate} 268*0Sstevel@tonic-gate# LEX_INTERPNORMAL test 269*0Sstevel@tonic-gatemy %e = ( a => 1 ); 270*0Sstevel@tonic-gateformat OUT4 = 271*0Sstevel@tonic-gate@<<<<<< 272*0Sstevel@tonic-gate"$e{a}" 273*0Sstevel@tonic-gate. 274*0Sstevel@tonic-gateopen OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; 275*0Sstevel@tonic-gatewrite (OUT4); 276*0Sstevel@tonic-gateclose OUT4 or die "Could not close: $!"; 277*0Sstevel@tonic-gateif (cat('Op_write.tmp') eq "1\n") { 278*0Sstevel@tonic-gate print "ok 9\n"; 279*0Sstevel@tonic-gate 1 while unlink "Op_write.tmp"; 280*0Sstevel@tonic-gate } 281*0Sstevel@tonic-gateelse { 282*0Sstevel@tonic-gate print "not ok 9\n"; 283*0Sstevel@tonic-gate } 284*0Sstevel@tonic-gate 285*0Sstevel@tonic-gateeval <<'EOFORMAT'; 286*0Sstevel@tonic-gateformat OUT10 = 287*0Sstevel@tonic-gate@####.## @0###.## 288*0Sstevel@tonic-gate$test1, $test1 289*0Sstevel@tonic-gate. 290*0Sstevel@tonic-gateEOFORMAT 291*0Sstevel@tonic-gate 292*0Sstevel@tonic-gateopen(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 293*0Sstevel@tonic-gate 294*0Sstevel@tonic-gate$test1 = 12.95; 295*0Sstevel@tonic-gatewrite(OUT10); 296*0Sstevel@tonic-gateclose OUT10 or die "Could not close: $!"; 297*0Sstevel@tonic-gate 298*0Sstevel@tonic-gate$right = " 12.95 00012.95\n"; 299*0Sstevel@tonic-gateif (cat('Op_write.tmp') eq $right) 300*0Sstevel@tonic-gate { print "ok 10\n"; 1 while unlink 'Op_write.tmp'; } 301*0Sstevel@tonic-gateelse 302*0Sstevel@tonic-gate { print "not ok 10\n"; } 303*0Sstevel@tonic-gate 304*0Sstevel@tonic-gateeval <<'EOFORMAT'; 305*0Sstevel@tonic-gateformat OUT11 = 306*0Sstevel@tonic-gate@0###.## 307*0Sstevel@tonic-gate$test1 308*0Sstevel@tonic-gate@ 0# 309*0Sstevel@tonic-gate$test1 310*0Sstevel@tonic-gate@0 # 311*0Sstevel@tonic-gate$test1 312*0Sstevel@tonic-gate. 313*0Sstevel@tonic-gateEOFORMAT 314*0Sstevel@tonic-gate 315*0Sstevel@tonic-gateopen(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 316*0Sstevel@tonic-gate 317*0Sstevel@tonic-gate$test1 = 12.95; 318*0Sstevel@tonic-gatewrite(OUT11); 319*0Sstevel@tonic-gateclose OUT11 or die "Could not close: $!"; 320*0Sstevel@tonic-gate 321*0Sstevel@tonic-gate$right = 322*0Sstevel@tonic-gate"00012.95 323*0Sstevel@tonic-gate1 0# 324*0Sstevel@tonic-gate10 #\n"; 325*0Sstevel@tonic-gateif (cat('Op_write.tmp') eq $right) 326*0Sstevel@tonic-gate { print "ok 11\n"; 1 while unlink 'Op_write.tmp'; } 327*0Sstevel@tonic-gateelse 328*0Sstevel@tonic-gate { print "not ok 11\n"; } 329*0Sstevel@tonic-gate 330*0Sstevel@tonic-gate{ 331*0Sstevel@tonic-gate our $el; 332*0Sstevel@tonic-gate format OUT12 = 333*0Sstevel@tonic-gateok ^<<<<<<<<<<<<<<~~ # sv_chop() naze 334*0Sstevel@tonic-gate$el 335*0Sstevel@tonic-gate. 336*0Sstevel@tonic-gate my %hash = (12 => 3); 337*0Sstevel@tonic-gate open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 338*0Sstevel@tonic-gate 339*0Sstevel@tonic-gate for $el (keys %hash) { 340*0Sstevel@tonic-gate write(OUT12); 341*0Sstevel@tonic-gate } 342*0Sstevel@tonic-gate close OUT12 or die "Could not close: $!"; 343*0Sstevel@tonic-gate print cat('Op_write.tmp'); 344*0Sstevel@tonic-gate 345*0Sstevel@tonic-gate} 346*0Sstevel@tonic-gate 347*0Sstevel@tonic-gate{ 348*0Sstevel@tonic-gate # Bug report and testcase by Alexey Tourbin 349*0Sstevel@tonic-gate use Tie::Scalar; 350*0Sstevel@tonic-gate my $v; 351*0Sstevel@tonic-gate tie $v, 'Tie::StdScalar'; 352*0Sstevel@tonic-gate $v = 13; 353*0Sstevel@tonic-gate format OUT13 = 354*0Sstevel@tonic-gateok ^<<<<<<<<< ~~ 355*0Sstevel@tonic-gate$v 356*0Sstevel@tonic-gate. 357*0Sstevel@tonic-gate open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 358*0Sstevel@tonic-gate write(OUT13); 359*0Sstevel@tonic-gate close OUT13 or die "Could not close: $!"; 360*0Sstevel@tonic-gate print cat('Op_write.tmp'); 361*0Sstevel@tonic-gate} 362*0Sstevel@tonic-gate 363*0Sstevel@tonic-gate{ # test 14 364*0Sstevel@tonic-gate # Bug #24774 format without trailing \n failed assertion, but this 365*0Sstevel@tonic-gate # must fail since we have a trailing ; in the eval'ed string (WL) 366*0Sstevel@tonic-gate my @v = ('k'); 367*0Sstevel@tonic-gate eval "format OUT14 = \n@\n\@v"; 368*0Sstevel@tonic-gate print $@ ? "ok 14\n" : "not ok 14\n"; 369*0Sstevel@tonic-gate 370*0Sstevel@tonic-gate} 371*0Sstevel@tonic-gate 372*0Sstevel@tonic-gate{ # test 15 373*0Sstevel@tonic-gate # text lost in ^<<< field with \r in value (WL) 374*0Sstevel@tonic-gate my $txt = "line 1\rline 2"; 375*0Sstevel@tonic-gate format OUT15 = 376*0Sstevel@tonic-gate^<<<<<<<<<<<<<<<<<< 377*0Sstevel@tonic-gate$txt 378*0Sstevel@tonic-gate^<<<<<<<<<<<<<<<<<< 379*0Sstevel@tonic-gate$txt 380*0Sstevel@tonic-gate. 381*0Sstevel@tonic-gate open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 382*0Sstevel@tonic-gate write(OUT15); 383*0Sstevel@tonic-gate close OUT15 or die "Could not close: $!"; 384*0Sstevel@tonic-gate my $res = cat('Op_write.tmp'); 385*0Sstevel@tonic-gate print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n"; 386*0Sstevel@tonic-gate} 387*0Sstevel@tonic-gate 388*0Sstevel@tonic-gate{ # test 16: multiple use of a variable in same line with ^< 389*0Sstevel@tonic-gate my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; 390*0Sstevel@tonic-gate format OUT16 = 391*0Sstevel@tonic-gate^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 392*0Sstevel@tonic-gate$txt, $txt 393*0Sstevel@tonic-gate^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< 394*0Sstevel@tonic-gate$txt, $txt 395*0Sstevel@tonic-gate. 396*0Sstevel@tonic-gate open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 397*0Sstevel@tonic-gate write(OUT16); 398*0Sstevel@tonic-gate close OUT16 or die "Could not close: $!"; 399*0Sstevel@tonic-gate my $res = cat('Op_write.tmp'); 400*0Sstevel@tonic-gate print $res eq <<EOD ? "ok 16\n" : "not ok 16\n"; 401*0Sstevel@tonic-gatethis_is_block_1 this_is_block_2 402*0Sstevel@tonic-gatethis_is_block_3 this_is_block_4 403*0Sstevel@tonic-gateEOD 404*0Sstevel@tonic-gate} 405*0Sstevel@tonic-gate 406*0Sstevel@tonic-gate{ # test 17: @* "should be on a line of its own", but it should work 407*0Sstevel@tonic-gate # cleanly with literals before and after. (WL) 408*0Sstevel@tonic-gate 409*0Sstevel@tonic-gate my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; 410*0Sstevel@tonic-gate format OUT17 = 411*0Sstevel@tonic-gateHere we go: @* That's all, folks! 412*0Sstevel@tonic-gate $txt 413*0Sstevel@tonic-gate. 414*0Sstevel@tonic-gate open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 415*0Sstevel@tonic-gate write(OUT17); 416*0Sstevel@tonic-gate close OUT17 or die "Could not close: $!"; 417*0Sstevel@tonic-gate my $res = cat('Op_write.tmp'); 418*0Sstevel@tonic-gate chomp( $txt ); 419*0Sstevel@tonic-gate my $exp = <<EOD; 420*0Sstevel@tonic-gateHere we go: $txt That's all, folks! 421*0Sstevel@tonic-gateEOD 422*0Sstevel@tonic-gate print $res eq $exp ? "ok 17\n" : "not ok 17\n"; 423*0Sstevel@tonic-gate} 424*0Sstevel@tonic-gate 425*0Sstevel@tonic-gate{ # test 18: @# and ~~ would cause runaway format, but we now 426*0Sstevel@tonic-gate # catch this while compiling (WL) 427*0Sstevel@tonic-gate 428*0Sstevel@tonic-gate format OUT18 = 429*0Sstevel@tonic-gate@######## ~~ 430*0Sstevel@tonic-gate10 431*0Sstevel@tonic-gate. 432*0Sstevel@tonic-gate open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 433*0Sstevel@tonic-gate eval { write(OUT18); }; 434*0Sstevel@tonic-gate print $@ ? "ok 18\n" : "not ok 18\n"; 435*0Sstevel@tonic-gate close OUT18 or die "Could not close: $!"; 436*0Sstevel@tonic-gate} 437*0Sstevel@tonic-gate 438*0Sstevel@tonic-gate{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) 439*0Sstevel@tonic-gate my $v = 'gaga'; 440*0Sstevel@tonic-gate eval "format OUT19 = \n" . 441*0Sstevel@tonic-gate '@<<<' . "\0\n" . 442*0Sstevel@tonic-gate '$v' . "\n" . 443*0Sstevel@tonic-gate '@<<<' . "\0\n" . 444*0Sstevel@tonic-gate '$v' . "\n.\n"; 445*0Sstevel@tonic-gate open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 446*0Sstevel@tonic-gate write(OUT19); 447*0Sstevel@tonic-gate close OUT19 or die "Could not close: $!"; 448*0Sstevel@tonic-gate my $res = cat('Op_write.tmp'); 449*0Sstevel@tonic-gate print $res eq <<EOD ? "ok 19\n" : "not ok 19\n"; 450*0Sstevel@tonic-gategaga\0 451*0Sstevel@tonic-gategaga\0 452*0Sstevel@tonic-gateEOD 453*0Sstevel@tonic-gate} 454*0Sstevel@tonic-gate 455*0Sstevel@tonic-gate{ # test 20: hash accesses; single '}' must not terminate format '}' (WL) 456*0Sstevel@tonic-gate my %h = ( xkey => 'xval', ykey => 'yval' ); 457*0Sstevel@tonic-gate format OUT20 = 458*0Sstevel@tonic-gate@>>>> @<<<< ~~ 459*0Sstevel@tonic-gateeach %h 460*0Sstevel@tonic-gate@>>>> @<<<< 461*0Sstevel@tonic-gate$h{xkey}, $h{ykey} 462*0Sstevel@tonic-gate@>>>> @<<<< 463*0Sstevel@tonic-gate{ $h{xkey}, $h{ykey} 464*0Sstevel@tonic-gate} 465*0Sstevel@tonic-gate} 466*0Sstevel@tonic-gate. 467*0Sstevel@tonic-gate my $exp = ''; 468*0Sstevel@tonic-gate while( my( $k, $v ) = each( %h ) ){ 469*0Sstevel@tonic-gate $exp .= sprintf( "%5s %s\n", $k, $v ); 470*0Sstevel@tonic-gate } 471*0Sstevel@tonic-gate $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 472*0Sstevel@tonic-gate $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); 473*0Sstevel@tonic-gate $exp .= "}\n"; 474*0Sstevel@tonic-gate open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; 475*0Sstevel@tonic-gate write(OUT20); 476*0Sstevel@tonic-gate close OUT20 or die "Could not close: $!"; 477*0Sstevel@tonic-gate my $res = cat('Op_write.tmp'); 478*0Sstevel@tonic-gate print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n"; 479*0Sstevel@tonic-gate} 480*0Sstevel@tonic-gate 481*0Sstevel@tonic-gate 482*0Sstevel@tonic-gate##################### 483*0Sstevel@tonic-gate## Section 2 484*0Sstevel@tonic-gate## numeric formatting 485*0Sstevel@tonic-gate##################### 486*0Sstevel@tonic-gate 487*0Sstevel@tonic-gatemy $nt = $bas_tests; 488*0Sstevel@tonic-gatefor my $tref ( @NumTests ){ 489*0Sstevel@tonic-gate my $writefmt = shift( @$tref ); 490*0Sstevel@tonic-gate while (@$tref) { 491*0Sstevel@tonic-gate my $val = shift @$tref; 492*0Sstevel@tonic-gate my $expected = shift @$tref; 493*0Sstevel@tonic-gate my $writeres = swrite( $writefmt, $val ); 494*0Sstevel@tonic-gate $nt++; 495*0Sstevel@tonic-gate my $ok = ref($expected) 496*0Sstevel@tonic-gate ? $writeres =~ $expected 497*0Sstevel@tonic-gate : $writeres eq $expected; 498*0Sstevel@tonic-gate 499*0Sstevel@tonic-gate print $ok 500*0Sstevel@tonic-gate ? "ok $nt - $writefmt\n" 501*0Sstevel@tonic-gate : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n"; 502*0Sstevel@tonic-gate } 503*0Sstevel@tonic-gate} 504*0Sstevel@tonic-gate 505*0Sstevel@tonic-gate 506*0Sstevel@tonic-gate##################################### 507*0Sstevel@tonic-gate## Section 3 508*0Sstevel@tonic-gate## Easiest to add new tests above here 509*0Sstevel@tonic-gate####################################### 510*0Sstevel@tonic-gate 511*0Sstevel@tonic-gate# scary format testing from H.Merijn Brand 512*0Sstevel@tonic-gate 513*0Sstevel@tonic-gatemy $test = $bas_tests + $num_tests + 1; 514*0Sstevel@tonic-gatemy $tests = $bas_tests + $num_tests + $hmb_tests; 515*0Sstevel@tonic-gate 516*0Sstevel@tonic-gateif ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || 517*0Sstevel@tonic-gate ($^O eq 'os2' and not eval '$OS2::can_fork')) { 518*0Sstevel@tonic-gate foreach ($test..$tests) { 519*0Sstevel@tonic-gate print "ok $_ # skipped: '|-' and '-|' not supported\n"; 520*0Sstevel@tonic-gate } 521*0Sstevel@tonic-gate exit(0); 522*0Sstevel@tonic-gate} 523*0Sstevel@tonic-gate 524*0Sstevel@tonic-gate 525*0Sstevel@tonic-gateuse strict; # Amazed that this hackery can be made strict ... 526*0Sstevel@tonic-gate 527*0Sstevel@tonic-gate# Just a complete test for format, including top-, left- and bottom marging 528*0Sstevel@tonic-gate# and format detection through glob entries 529*0Sstevel@tonic-gate 530*0Sstevel@tonic-gateformat EMPTY = 531*0Sstevel@tonic-gate. 532*0Sstevel@tonic-gate 533*0Sstevel@tonic-gateformat Comment = 534*0Sstevel@tonic-gateok @<<<<< 535*0Sstevel@tonic-gate$test 536*0Sstevel@tonic-gate. 537*0Sstevel@tonic-gate 538*0Sstevel@tonic-gate 539*0Sstevel@tonic-gate# [ID 20020227.005] format bug with undefined _TOP 540*0Sstevel@tonic-gate 541*0Sstevel@tonic-gateopen STDOUT_DUP, ">&STDOUT"; 542*0Sstevel@tonic-gatemy $oldfh = select STDOUT_DUP; 543*0Sstevel@tonic-gate$= = 10; 544*0Sstevel@tonic-gate{ local $~ = "Comment"; 545*0Sstevel@tonic-gate write; 546*0Sstevel@tonic-gate $test++; 547*0Sstevel@tonic-gate print $- == 9 548*0Sstevel@tonic-gate ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n"; 549*0Sstevel@tonic-gate $test++; 550*0Sstevel@tonic-gate print $^ eq "STDOUT_DUP_TOP" 551*0Sstevel@tonic-gate ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n"; 552*0Sstevel@tonic-gate $test++; 553*0Sstevel@tonic-gate} 554*0Sstevel@tonic-gateselect $oldfh; 555*0Sstevel@tonic-gateclose STDOUT_DUP; 556*0Sstevel@tonic-gate 557*0Sstevel@tonic-gate$^ = "STDOUT_TOP"; 558*0Sstevel@tonic-gate$= = 7; # Page length 559*0Sstevel@tonic-gate$- = 0; # Lines left 560*0Sstevel@tonic-gatemy $ps = $^L; $^L = ""; # Catch the page separator 561*0Sstevel@tonic-gatemy $tm = 1; # Top margin (empty lines before first output) 562*0Sstevel@tonic-gatemy $bm = 2; # Bottom marging (empty lines between last text and footer) 563*0Sstevel@tonic-gatemy $lm = 4; # Left margin (indent in spaces) 564*0Sstevel@tonic-gate 565*0Sstevel@tonic-gate# ----------------------------------------------------------------------- 566*0Sstevel@tonic-gate# 567*0Sstevel@tonic-gate# execute the rest of the script in a child process. The parent reads the 568*0Sstevel@tonic-gate# output from the child and compares it with <DATA>. 569*0Sstevel@tonic-gate 570*0Sstevel@tonic-gatemy @data = <DATA>; 571*0Sstevel@tonic-gate 572*0Sstevel@tonic-gateselect ((select (STDOUT), $| = 1)[0]); # flush STDOUT 573*0Sstevel@tonic-gate 574*0Sstevel@tonic-gatemy $opened = open FROM_CHILD, "-|"; 575*0Sstevel@tonic-gateunless (defined $opened) { 576*0Sstevel@tonic-gate print "not ok $test - open gave $!\n"; exit 0; 577*0Sstevel@tonic-gate} 578*0Sstevel@tonic-gate 579*0Sstevel@tonic-gateif ($opened) { 580*0Sstevel@tonic-gate # in parent here 581*0Sstevel@tonic-gate 582*0Sstevel@tonic-gate print "ok $test - open\n"; $test++; 583*0Sstevel@tonic-gate my $s = " " x $lm; 584*0Sstevel@tonic-gate while (<FROM_CHILD>) { 585*0Sstevel@tonic-gate unless (@data) { 586*0Sstevel@tonic-gate print "not ok $test - too much output\n"; 587*0Sstevel@tonic-gate exit; 588*0Sstevel@tonic-gate } 589*0Sstevel@tonic-gate s/^/$s/; 590*0Sstevel@tonic-gate my $exp = shift @data; 591*0Sstevel@tonic-gate print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n"; 592*0Sstevel@tonic-gate if ($_ ne $exp) { 593*0Sstevel@tonic-gate s/\n/\\n/g for $_, $exp; 594*0Sstevel@tonic-gate print "#expected: $exp\n#got: $_\n"; 595*0Sstevel@tonic-gate } 596*0Sstevel@tonic-gate } 597*0Sstevel@tonic-gate close FROM_CHILD; 598*0Sstevel@tonic-gate print + (@data?"not ":""), "ok ", $test++, " - too litle output\n"; 599*0Sstevel@tonic-gate exit; 600*0Sstevel@tonic-gate} 601*0Sstevel@tonic-gate 602*0Sstevel@tonic-gate# in child here 603*0Sstevel@tonic-gate 604*0Sstevel@tonic-gate select ((select (STDOUT), $| = 1)[0]); 605*0Sstevel@tonic-gate$tm = "\n" x $tm; 606*0Sstevel@tonic-gate$= -= $bm + 1; # count one for the trailing "----" 607*0Sstevel@tonic-gatemy $lastmin = 0; 608*0Sstevel@tonic-gate 609*0Sstevel@tonic-gatemy @E; 610*0Sstevel@tonic-gate 611*0Sstevel@tonic-gatesub wryte 612*0Sstevel@tonic-gate{ 613*0Sstevel@tonic-gate $lastmin = $-; 614*0Sstevel@tonic-gate write; 615*0Sstevel@tonic-gate } # wryte; 616*0Sstevel@tonic-gate 617*0Sstevel@tonic-gatesub footer 618*0Sstevel@tonic-gate{ 619*0Sstevel@tonic-gate $% == 1 and return ""; 620*0Sstevel@tonic-gate 621*0Sstevel@tonic-gate $lastmin < $= and print "\n" x $lastmin; 622*0Sstevel@tonic-gate print "\n" x $bm, "----\n", $ps; 623*0Sstevel@tonic-gate $lastmin = $-; 624*0Sstevel@tonic-gate ""; 625*0Sstevel@tonic-gate } # footer 626*0Sstevel@tonic-gate 627*0Sstevel@tonic-gate# Yes, this is sick ;-) 628*0Sstevel@tonic-gateformat TOP = 629*0Sstevel@tonic-gate@* ~ 630*0Sstevel@tonic-gate@{[footer]} 631*0Sstevel@tonic-gate@* ~ 632*0Sstevel@tonic-gate$tm 633*0Sstevel@tonic-gate. 634*0Sstevel@tonic-gate 635*0Sstevel@tonic-gateformat ENTRY = 636*0Sstevel@tonic-gate@ @<<<<~~ 637*0Sstevel@tonic-gate@{(shift @E)||["",""]} 638*0Sstevel@tonic-gate. 639*0Sstevel@tonic-gate 640*0Sstevel@tonic-gateformat EOR = 641*0Sstevel@tonic-gate- ----- 642*0Sstevel@tonic-gate. 643*0Sstevel@tonic-gate 644*0Sstevel@tonic-gatesub has_format ($) 645*0Sstevel@tonic-gate{ 646*0Sstevel@tonic-gate my $fmt = shift; 647*0Sstevel@tonic-gate exists $::{$fmt} or return 0; 648*0Sstevel@tonic-gate $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; 649*0Sstevel@tonic-gate open my $null, "> /dev/null" or die; 650*0Sstevel@tonic-gate my $fh = select $null; 651*0Sstevel@tonic-gate local $~ = $fmt; 652*0Sstevel@tonic-gate eval "write"; 653*0Sstevel@tonic-gate select $fh; 654*0Sstevel@tonic-gate $@?0:1; 655*0Sstevel@tonic-gate } # has_format 656*0Sstevel@tonic-gate 657*0Sstevel@tonic-gate$^ = has_format ("TOP") ? "TOP" : "EMPTY"; 658*0Sstevel@tonic-gatehas_format ("ENTRY") or die "No format defined for ENTRY"; 659*0Sstevel@tonic-gateforeach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], 660*0Sstevel@tonic-gate [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { 661*0Sstevel@tonic-gate @E = @$e; 662*0Sstevel@tonic-gate local $~ = "ENTRY"; 663*0Sstevel@tonic-gate wryte; 664*0Sstevel@tonic-gate has_format ("EOR") or next; 665*0Sstevel@tonic-gate local $~ = "EOR"; 666*0Sstevel@tonic-gate wryte; 667*0Sstevel@tonic-gate } 668*0Sstevel@tonic-gateif (has_format ("EOF")) { 669*0Sstevel@tonic-gate local $~ = "EOF"; 670*0Sstevel@tonic-gate wryte; 671*0Sstevel@tonic-gate } 672*0Sstevel@tonic-gate 673*0Sstevel@tonic-gateclose STDOUT; 674*0Sstevel@tonic-gate 675*0Sstevel@tonic-gate# That was test 48. 676*0Sstevel@tonic-gate 677*0Sstevel@tonic-gate__END__ 678*0Sstevel@tonic-gate 679*0Sstevel@tonic-gate 1 Test1 680*0Sstevel@tonic-gate 2 Test2 681*0Sstevel@tonic-gate 3 Test3 682*0Sstevel@tonic-gate 683*0Sstevel@tonic-gate 684*0Sstevel@tonic-gate ---- 685*0Sstevel@tonic-gate 686*0Sstevel@tonic-gate 4 Test4 687*0Sstevel@tonic-gate 5 Test5 688*0Sstevel@tonic-gate 6 Test6 689*0Sstevel@tonic-gate 690*0Sstevel@tonic-gate 691*0Sstevel@tonic-gate ---- 692*0Sstevel@tonic-gate 693*0Sstevel@tonic-gate 7 Test7 694*0Sstevel@tonic-gate - ----- 695*0Sstevel@tonic-gate 696*0Sstevel@tonic-gate 697*0Sstevel@tonic-gate 698*0Sstevel@tonic-gate ---- 699*0Sstevel@tonic-gate 700*0Sstevel@tonic-gate 1 1tseT 701*0Sstevel@tonic-gate 2 2tseT 702*0Sstevel@tonic-gate 3 3tseT 703*0Sstevel@tonic-gate 704*0Sstevel@tonic-gate 705*0Sstevel@tonic-gate ---- 706*0Sstevel@tonic-gate 707*0Sstevel@tonic-gate 4 4tseT 708*0Sstevel@tonic-gate 5 5tseT 709*0Sstevel@tonic-gate - ----- 710