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