Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
9ccde9ea |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
a1b95068 |
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 |
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 |
37 | |
38 | ); |
39 | |
a1b95068 |
40 | |
41 | my $num_tests = 0; |
42 | for my $tref ( @NumTests ){ |
d1f6232e |
43 | $num_tests += (@$tref - 1)/2; |
a1b95068 |
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 |
56 | : ($^O eq 'MacOS') ? 'catenate' |
57 | : 'cat'; |
3fe9a6f1 |
58 | |
a1b95068 |
59 | ############ |
60 | ## Section 1 |
61 | ############ |
62 | |
a687059c |
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 |
76 | { |
77 | 'i' . 's', "time\n", $good, 'to' |
78 | } |
a687059c |
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 |
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 |
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 |
104 | else |
105 | { print "not ok 1\n"; } |
106 | |
748a9306 |
107 | $fox = 'wolfishness'; |
108 | my $fox = 'foxiness'; # Test a lexical variable. |
109 | |
a687059c |
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 |
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 |
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 |
146 | else |
147 | { print "not ok 2\n"; } |
148 | |
0f85fab0 |
149 | eval <<'EOFORMAT'; |
150 | format OUT2 = |
151 | the brown quick @<< |
152 | $fox |
153 | jumped |
154 | @* |
155 | $multiline |
a0d0e21e |
156 | and |
0f85fab0 |
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 |
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 |
172 | |
173 | $right = |
174 | "the brown quick fox |
175 | jumped |
176 | forescore |
177 | and |
178 | seven years |
a0d0e21e |
179 | and |
0f85fab0 |
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 |
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 |
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 |
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 |
245 | else |
246 | { print "not ok 6\n"; } |
247 | |
445b3f51 |
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 |
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 |
271 | if (`$CAT Op_write.tmp` eq "1\n") { |
272 | print "ok 9\n"; |
784707d5 |
273 | 1 while unlink "Op_write.tmp"; |
c2e66d9e |
274 | } |
275 | else { |
276 | print "not ok 9\n"; |
277 | } |
784707d5 |
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 |
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 |
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 |
327 | ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze |
328 | $el |
329 | . |
330 | my %hash = (12 => 3); |
a1b95068 |
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 |
336 | close OUT12 or die "Could not close: $!"; |
337 | print `$CAT Op_write.tmp`; |
338 | |
31869a79 |
339 | } |
340 | |
ea42cebc |
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 |
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 |
360 | my @v = ('k'); |
361 | eval "format OUT14 = \n@\n\@v"; |
c5ee2135 |
362 | print $@ ? "ok 14\n" : "not ok 14\n"; |
363 | |
f5c235e7 |
364 | } |
365 | |
a1b95068 |
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 |
484 | while (@$tref) { |
485 | my $val = shift @$tref; |
486 | my $expected = shift @$tref; |
a1b95068 |
487 | my $writeres = swrite( $writefmt, $val ); |
a1b95068 |
488 | $nt++; |
8975a8c2 |
489 | my $ok = ref($expected) |
490 | ? $writeres =~ $expected |
491 | : $writeres eq $expected; |
492 | |
493 | print $ok |
176ab42a |
494 | ? "ok $nt\n" |
495 | : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n"; |
a1b95068 |
496 | } |
497 | } |
498 | |
499 | |
500 | ##################################### |
501 | ## Section 3 |
502 | ## Easiest to add new tests above here |
ea42cebc |
503 | ####################################### |
504 | |
a1b95068 |
505 | # scary format testing from H.Merijn Brand |
ea42cebc |
506 | |
a1b95068 |
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 |
512 | foreach ($test..$tests) { |
513 | print "ok $_ # skipped: '|-' and '-|' not supported\n"; |
514 | } |
d4a0c6f3 |
515 | exit(0); |
516 | } |
517 | |
9ccde9ea |
518 | |
ea42cebc |
519 | use strict; # Amazed that this hackery can be made strict ... |
d57f9278 |
520 | |
9ccde9ea |
521 | # Just a complete test for format, including top-, left- and bottom marging |
522 | # and format detection through glob entries |
523 | |
d57f9278 |
524 | format EMPTY = |
525 | . |
526 | |
527 | format Comment = |
528 | ok @<<<<< |
529 | $test |
530 | . |
531 | |
d57f9278 |
532 | |
533 | # [ID 20020227.005] format bug with undefined _TOP |
0bd0581c |
534 | |
535 | open STDOUT_DUP, ">&STDOUT"; |
536 | my $oldfh = select STDOUT_DUP; |
537 | $= = 10; |
d57f9278 |
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 |
544 | print $^ eq "STDOUT_DUP_TOP" |
545 | ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n"; |
d57f9278 |
546 | $test++; |
0bd0581c |
547 | } |
548 | select $oldfh; |
d57f9278 |
549 | |
0bd0581c |
550 | $^ = "STDOUT_TOP"; |
551 | $= = 7; # Page length |
552 | $- = 0; # Lines left |
9ccde9ea |
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 |
561 | my $s = " " x $lm; |
562 | while (<STDIN>) { |
563 | s/^/$s/; |
d57f9278 |
564 | print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n"; |
9ccde9ea |
565 | } |
566 | close STDIN; |
d57f9278 |
567 | print + (<DATA>?"not ":""), "ok ", $test++, "\n"; |
9ccde9ea |
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 |
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 |
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 |
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 | - ----- |