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