Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
9ccde9ea JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
a344b90b DM |
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 WL |
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 DM |
29 | [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', |
30 | 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], | |
d1f6232e | 31 | |
9acd3e2c DM |
32 | [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', |
33 | -999.4999, '-999', -999.6, '####', 1e+100, '####' ], | |
d1f6232e DM |
34 | |
35 | [ '^###', 0, ' 0', undef, ' ' ], | |
36 | ||
37 | [ '^0##', 0, '0000', undef, ' ' ], | |
38 | ||
9acd3e2c DM |
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 DM |
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 DM |
47 | |
48 | ); | |
49 | ||
a1b95068 WL |
50 | |
51 | my $num_tests = 0; | |
52 | for my $tref ( @NumTests ){ | |
d1f6232e | 53 | $num_tests += (@$tref - 1)/2; |
a1b95068 WL |
54 | } |
55 | #--------------------------------------------------------- | |
56 | ||
57 | # number of tests in section 1 | |
58 | my $bas_tests = 20; | |
59 | ||
60 | # number of tests in section 3 | |
68ba3c2c | 61 | my $hmb_tests = 37; |
a1b95068 WL |
62 | |
63 | printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests; | |
a687059c | 64 | |
a1b95068 WL |
65 | ############ |
66 | ## Section 1 | |
67 | ############ | |
68 | ||
a687059c LW |
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 LW |
82 | { |
83 | 'i' . 's', "time\n", $good, 'to' | |
84 | } | |
a687059c LW |
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 LW |
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 LW |
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 LW |
110 | else |
111 | { print "not ok 1\n"; } | |
112 | ||
748a9306 LW |
113 | $fox = 'wolfishness'; |
114 | my $fox = 'foxiness'; # Test a lexical variable. | |
115 | ||
a687059c LW |
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 LW |
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 LW |
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 LW |
152 | else |
153 | { print "not ok 2\n"; } | |
154 | ||
0f85fab0 LW |
155 | eval <<'EOFORMAT'; |
156 | format OUT2 = | |
157 | the brown quick @<< | |
158 | $fox | |
159 | jumped | |
160 | @* | |
161 | $multiline | |
a0d0e21e | 162 | and |
0f85fab0 LW |
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 LW |
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 LW |
178 | |
179 | $right = | |
180 | "the brown quick fox | |
181 | jumped | |
182 | forescore | |
183 | and | |
184 | seven years | |
a0d0e21e | 185 | and |
0f85fab0 LW |
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 LW |
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 KM |
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 KM |
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 KM |
251 | else |
252 | { print "not ok 6\n"; } | |
253 | ||
445b3f51 GS |
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 GS |
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 GS |
280 | } |
281 | else { | |
282 | print "not ok 9\n"; | |
283 | } | |
784707d5 JP |
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 JP |
297 | |
298 | $right = " 12.95 00012.95\n"; | |
a344b90b | 299 | if (cat('Op_write.tmp') eq $right) |
784707d5 JP |
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 JP |
320 | |
321 | $right = | |
322 | "00012.95 | |
323 | 1 0# | |
324 | 10 #\n"; | |
a344b90b | 325 | if (cat('Op_write.tmp') eq $right) |
784707d5 JP |
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 AE |
333 | ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze |
334 | $el | |
335 | . | |
336 | my %hash = (12 => 3); | |
a1b95068 WL |
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 AE |
345 | } |
346 | ||
ea42cebc RGS |
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 RGS |
361 | } |
362 | ||
a1b95068 WL |
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 DM |
366 | my @v = ('k'); |
367 | eval "format OUT14 = \n@\n\@v"; | |
ee09ed4c NC |
368 | print +($@ && $@ =~ /Format not terminated/) |
369 | ? "ok 14\n" : "not ok 14 $@\n"; | |
c5ee2135 | 370 | |
f5c235e7 DM |
371 | } |
372 | ||
a1b95068 WL |
373 | { # test 15 |
374 | # text lost in ^<<< field with \r in value (WL) | |
375 | my $txt = "line 1\rline 2"; | |
376 | format OUT15 = | |
377 | ^<<<<<<<<<<<<<<<<<< | |
378 | $txt | |
379 | ^<<<<<<<<<<<<<<<<<< | |
380 | $txt | |
381 | . | |
382 | open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
383 | write(OUT15); | |
384 | close OUT15 or die "Could not close: $!"; | |
a344b90b | 385 | my $res = cat('Op_write.tmp'); |
a1b95068 WL |
386 | print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n"; |
387 | } | |
388 | ||
389 | { # test 16: multiple use of a variable in same line with ^< | |
390 | my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; | |
391 | format OUT16 = | |
392 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< | |
393 | $txt, $txt | |
394 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< | |
395 | $txt, $txt | |
396 | . | |
397 | open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
398 | write(OUT16); | |
399 | close OUT16 or die "Could not close: $!"; | |
a344b90b | 400 | my $res = cat('Op_write.tmp'); |
a1b95068 WL |
401 | print $res eq <<EOD ? "ok 16\n" : "not ok 16\n"; |
402 | this_is_block_1 this_is_block_2 | |
403 | this_is_block_3 this_is_block_4 | |
404 | EOD | |
405 | } | |
406 | ||
407 | { # test 17: @* "should be on a line of its own", but it should work | |
408 | # cleanly with literals before and after. (WL) | |
409 | ||
410 | my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; | |
411 | format OUT17 = | |
412 | Here we go: @* That's all, folks! | |
413 | $txt | |
414 | . | |
415 | open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
416 | write(OUT17); | |
417 | close OUT17 or die "Could not close: $!"; | |
a344b90b | 418 | my $res = cat('Op_write.tmp'); |
a1b95068 WL |
419 | chomp( $txt ); |
420 | my $exp = <<EOD; | |
421 | Here we go: $txt That's all, folks! | |
422 | EOD | |
423 | print $res eq $exp ? "ok 17\n" : "not ok 17\n"; | |
424 | } | |
425 | ||
426 | { # test 18: @# and ~~ would cause runaway format, but we now | |
427 | # catch this while compiling (WL) | |
428 | ||
429 | format OUT18 = | |
430 | @######## ~~ | |
431 | 10 | |
432 | . | |
433 | open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
434 | eval { write(OUT18); }; | |
ee09ed4c NC |
435 | print +($@ && $@ =~ /Repeated format line will never terminate/) |
436 | ? "ok 18\n" : "not ok 18: $@\n"; | |
a1b95068 WL |
437 | close OUT18 or die "Could not close: $!"; |
438 | } | |
439 | ||
440 | { # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) | |
441 | my $v = 'gaga'; | |
442 | eval "format OUT19 = \n" . | |
443 | '@<<<' . "\0\n" . | |
444 | '$v' . "\n" . | |
445 | '@<<<' . "\0\n" . | |
446 | '$v' . "\n.\n"; | |
447 | open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
448 | write(OUT19); | |
a344b90b DM |
449 | close OUT19 or die "Could not close: $!"; |
450 | my $res = cat('Op_write.tmp'); | |
a1b95068 WL |
451 | print $res eq <<EOD ? "ok 19\n" : "not ok 19\n"; |
452 | gaga\0 | |
453 | gaga\0 | |
454 | EOD | |
455 | } | |
456 | ||
457 | { # test 20: hash accesses; single '}' must not terminate format '}' (WL) | |
458 | my %h = ( xkey => 'xval', ykey => 'yval' ); | |
459 | format OUT20 = | |
460 | @>>>> @<<<< ~~ | |
461 | each %h | |
462 | @>>>> @<<<< | |
463 | $h{xkey}, $h{ykey} | |
464 | @>>>> @<<<< | |
465 | { $h{xkey}, $h{ykey} | |
466 | } | |
467 | } | |
468 | . | |
469 | my $exp = ''; | |
470 | while( my( $k, $v ) = each( %h ) ){ | |
471 | $exp .= sprintf( "%5s %s\n", $k, $v ); | |
472 | } | |
473 | $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); | |
474 | $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); | |
475 | $exp .= "}\n"; | |
476 | open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
477 | write(OUT20); | |
a344b90b DM |
478 | close OUT20 or die "Could not close: $!"; |
479 | my $res = cat('Op_write.tmp'); | |
a1b95068 | 480 | print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n"; |
a1b95068 WL |
481 | } |
482 | ||
483 | ||
484 | ##################### | |
485 | ## Section 2 | |
486 | ## numeric formatting | |
487 | ##################### | |
488 | ||
489 | my $nt = $bas_tests; | |
490 | for my $tref ( @NumTests ){ | |
491 | my $writefmt = shift( @$tref ); | |
d1f6232e DM |
492 | while (@$tref) { |
493 | my $val = shift @$tref; | |
494 | my $expected = shift @$tref; | |
a1b95068 | 495 | my $writeres = swrite( $writefmt, $val ); |
a1b95068 | 496 | $nt++; |
8975a8c2 DM |
497 | my $ok = ref($expected) |
498 | ? $writeres =~ $expected | |
499 | : $writeres eq $expected; | |
500 | ||
501 | print $ok | |
68ba3c2c | 502 | ? "ok $nt - $writefmt\n" |
176ab42a | 503 | : "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n"; |
a1b95068 WL |
504 | } |
505 | } | |
506 | ||
507 | ||
508 | ##################################### | |
509 | ## Section 3 | |
510 | ## Easiest to add new tests above here | |
ea42cebc RGS |
511 | ####################################### |
512 | ||
a1b95068 | 513 | # scary format testing from H.Merijn Brand |
ea42cebc | 514 | |
a1b95068 WL |
515 | my $test = $bas_tests + $num_tests + 1; |
516 | my $tests = $bas_tests + $num_tests + $hmb_tests; | |
9ccde9ea | 517 | |
dc459aad | 518 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || |
764df951 | 519 | ($^O eq 'os2' and not eval '$OS2::can_fork')) { |
ea42cebc RGS |
520 | foreach ($test..$tests) { |
521 | print "ok $_ # skipped: '|-' and '-|' not supported\n"; | |
522 | } | |
d4a0c6f3 CB |
523 | exit(0); |
524 | } | |
525 | ||
9ccde9ea | 526 | |
ea42cebc | 527 | use strict; # Amazed that this hackery can be made strict ... |
d57f9278 | 528 | |
9ccde9ea JH |
529 | # Just a complete test for format, including top-, left- and bottom marging |
530 | # and format detection through glob entries | |
531 | ||
d57f9278 MB |
532 | format EMPTY = |
533 | . | |
534 | ||
535 | format Comment = | |
536 | ok @<<<<< | |
537 | $test | |
538 | . | |
539 | ||
d57f9278 MB |
540 | |
541 | # [ID 20020227.005] format bug with undefined _TOP | |
0bd0581c DM |
542 | |
543 | open STDOUT_DUP, ">&STDOUT"; | |
544 | my $oldfh = select STDOUT_DUP; | |
545 | $= = 10; | |
d57f9278 MB |
546 | { local $~ = "Comment"; |
547 | write; | |
548 | $test++; | |
549 | print $- == 9 | |
3444c34c | 550 | ? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n"; |
d57f9278 | 551 | $test++; |
0bd0581c DM |
552 | print $^ eq "STDOUT_DUP_TOP" |
553 | ? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n"; | |
d57f9278 | 554 | $test++; |
0bd0581c DM |
555 | } |
556 | select $oldfh; | |
68ba3c2c | 557 | close STDOUT_DUP; |
d57f9278 | 558 | |
0bd0581c DM |
559 | $^ = "STDOUT_TOP"; |
560 | $= = 7; # Page length | |
561 | $- = 0; # Lines left | |
9ccde9ea JH |
562 | my $ps = $^L; $^L = ""; # Catch the page separator |
563 | my $tm = 1; # Top margin (empty lines before first output) | |
564 | my $bm = 2; # Bottom marging (empty lines between last text and footer) | |
565 | my $lm = 4; # Left margin (indent in spaces) | |
566 | ||
68ba3c2c DM |
567 | # ----------------------------------------------------------------------- |
568 | # | |
569 | # execute the rest of the script in a child process. The parent reads the | |
570 | # output from the child and compares it with <DATA>. | |
571 | ||
572 | my @data = <DATA>; | |
573 | ||
574 | select ((select (STDOUT), $| = 1)[0]); # flush STDOUT | |
575 | ||
576 | my $opened = open FROM_CHILD, "-|"; | |
577 | unless (defined $opened) { | |
578 | print "not ok $test - open gave $!\n"; exit 0; | |
579 | } | |
580 | ||
581 | if ($opened) { | |
582 | # in parent here | |
583 | ||
584 | print "ok $test - open\n"; $test++; | |
9ccde9ea | 585 | my $s = " " x $lm; |
68ba3c2c DM |
586 | while (<FROM_CHILD>) { |
587 | unless (@data) { | |
588 | print "not ok $test - too much output\n"; | |
589 | exit; | |
590 | } | |
9ccde9ea | 591 | s/^/$s/; |
68ba3c2c DM |
592 | my $exp = shift @data; |
593 | print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n"; | |
594 | if ($_ ne $exp) { | |
595 | s/\n/\\n/g for $_, $exp; | |
596 | print "#expected: $exp\n#got: $_\n"; | |
9ccde9ea | 597 | } |
9ccde9ea | 598 | } |
68ba3c2c DM |
599 | close FROM_CHILD; |
600 | print + (@data?"not ":""), "ok ", $test++, " - too litle output\n"; | |
601 | exit; | |
602 | } | |
603 | ||
604 | # in child here | |
605 | ||
606 | select ((select (STDOUT), $| = 1)[0]); | |
9ccde9ea JH |
607 | $tm = "\n" x $tm; |
608 | $= -= $bm + 1; # count one for the trailing "----" | |
609 | my $lastmin = 0; | |
610 | ||
611 | my @E; | |
612 | ||
613 | sub wryte | |
614 | { | |
615 | $lastmin = $-; | |
616 | write; | |
617 | } # wryte; | |
618 | ||
619 | sub footer | |
620 | { | |
621 | $% == 1 and return ""; | |
622 | ||
623 | $lastmin < $= and print "\n" x $lastmin; | |
624 | print "\n" x $bm, "----\n", $ps; | |
625 | $lastmin = $-; | |
626 | ""; | |
627 | } # footer | |
628 | ||
629 | # Yes, this is sick ;-) | |
630 | format TOP = | |
631 | @* ~ | |
632 | @{[footer]} | |
633 | @* ~ | |
634 | $tm | |
635 | . | |
636 | ||
9ccde9ea JH |
637 | format ENTRY = |
638 | @ @<<<<~~ | |
639 | @{(shift @E)||["",""]} | |
640 | . | |
641 | ||
642 | format EOR = | |
643 | - ----- | |
644 | . | |
645 | ||
646 | sub has_format ($) | |
647 | { | |
648 | my $fmt = shift; | |
649 | exists $::{$fmt} or return 0; | |
650 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; | |
651 | open my $null, "> /dev/null" or die; | |
652 | my $fh = select $null; | |
653 | local $~ = $fmt; | |
654 | eval "write"; | |
655 | select $fh; | |
656 | $@?0:1; | |
657 | } # has_format | |
658 | ||
d57f9278 | 659 | $^ = has_format ("TOP") ? "TOP" : "EMPTY"; |
9ccde9ea JH |
660 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
661 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], | |
662 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { | |
663 | @E = @$e; | |
664 | local $~ = "ENTRY"; | |
665 | wryte; | |
666 | has_format ("EOR") or next; | |
667 | local $~ = "EOR"; | |
668 | wryte; | |
669 | } | |
670 | if (has_format ("EOF")) { | |
671 | local $~ = "EOF"; | |
672 | wryte; | |
673 | } | |
674 | ||
675 | close STDOUT; | |
676 | ||
ea42cebc | 677 | # That was test 48. |
9ccde9ea JH |
678 | |
679 | __END__ | |
680 | ||
681 | 1 Test1 | |
682 | 2 Test2 | |
683 | 3 Test3 | |
684 | ||
685 | ||
686 | ---- | |
687 | \f | |
688 | 4 Test4 | |
689 | 5 Test5 | |
690 | 6 Test6 | |
691 | ||
692 | ||
693 | ---- | |
694 | \f | |
695 | 7 Test7 | |
696 | - ----- | |
697 | ||
698 | ||
699 | ||
700 | ---- | |
701 | \f | |
702 | 1 1tseT | |
703 | 2 2tseT | |
704 | 3 3tseT | |
705 | ||
706 | ||
707 | ---- | |
708 | \f | |
709 | 4 4tseT | |
710 | 5 5tseT | |
711 | - ----- |