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