Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
9ccde9ea |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6108250c |
6 | require './test.pl'; |
9ccde9ea |
7 | } |
8 | |
90f67b00 |
9 | use strict; # Amazed that this hackery can be made strict ... |
10 | |
a344b90b |
11 | # read in a file |
12 | sub cat { |
13 | my $file = shift; |
14 | local $/; |
15 | open my $fh, $file or die "can't open '$file': $!"; |
16 | my $data = <$fh>; |
17 | close $fh; |
18 | $data; |
19 | } |
20 | |
a1b95068 |
21 | #-- testing numeric fields in all variants (WL) |
22 | |
23 | sub swrite { |
24 | my $format = shift; |
25 | local $^A = ""; # don't litter, use a local bin |
26 | formline( $format, @_ ); |
27 | return $^A; |
28 | } |
29 | |
30 | my @NumTests = ( |
d1f6232e |
31 | # [ format, value1, expected1, value2, expected2, .... ] |
9acd3e2c |
32 | [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', |
33 | 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], |
d1f6232e |
34 | |
9acd3e2c |
35 | [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', |
36 | -999.4999, '-999', -999.6, '####', 1e+100, '####' ], |
d1f6232e |
37 | |
38 | [ '^###', 0, ' 0', undef, ' ' ], |
39 | |
40 | [ '^0##', 0, '0000', undef, ' ' ], |
41 | |
9acd3e2c |
42 | [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', |
43 | 9999.4999, '9999.', -999.6, '#####' ], |
d1f6232e |
44 | |
9acd3e2c |
45 | [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', |
d1f6232e |
46 | 999.99499, '999.99', -100, '######' ], |
47 | |
48 | [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', |
8975a8c2 |
49 | -0.0001, qr/^[\-0]00\.00$/ ], |
d1f6232e |
50 | |
51 | ); |
52 | |
a1b95068 |
53 | |
54 | my $num_tests = 0; |
55 | for my $tref ( @NumTests ){ |
d1f6232e |
56 | $num_tests += (@$tref - 1)/2; |
a1b95068 |
57 | } |
58 | #--------------------------------------------------------- |
59 | |
60 | # number of tests in section 1 |
61 | my $bas_tests = 20; |
62 | |
63 | # number of tests in section 3 |
35c6393c |
64 | my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2; |
a1b95068 |
65 | |
f5b75c1c |
66 | # number of tests in section 4 |
67 | my $hmb_tests = 35; |
68 | |
69 | my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests; |
6108250c |
70 | |
71 | plan $tests; |
a687059c |
72 | |
a1b95068 |
73 | ############ |
74 | ## Section 1 |
75 | ############ |
76 | |
90f67b00 |
77 | use vars qw($fox $multiline $foo $good); |
78 | |
a687059c |
79 | format OUT = |
80 | the quick brown @<< |
81 | $fox |
82 | jumped |
83 | @* |
84 | $multiline |
85 | ^<<<<<<<<< |
86 | $foo |
87 | ^<<<<<<<<< |
88 | $foo |
89 | ^<<<<<<... |
90 | $foo |
91 | now @<<the@>>>> for all@|||||men to come @<<<< |
a0d0e21e |
92 | { |
93 | 'i' . 's', "time\n", $good, 'to' |
94 | } |
a687059c |
95 | . |
96 | |
a0d0e21e |
97 | open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
19f4d710 |
98 | END { 1 while unlink 'Op_write.tmp' } |
a687059c |
99 | |
100 | $fox = 'foxiness'; |
101 | $good = 'good'; |
102 | $multiline = "forescore\nand\nseven years\n"; |
103 | $foo = 'when in the course of human events it becomes necessary'; |
104 | write(OUT); |
d1e4d418 |
105 | close OUT or die "Could not close: $!"; |
a687059c |
106 | |
90f67b00 |
107 | my $right = |
a687059c |
108 | "the quick brown fox |
109 | jumped |
110 | forescore |
111 | and |
112 | seven years |
113 | when in |
114 | the course |
115 | of huma... |
116 | now is the time for all good men to come to\n"; |
117 | |
2027357e |
118 | is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; }; |
a687059c |
119 | |
748a9306 |
120 | $fox = 'wolfishness'; |
121 | my $fox = 'foxiness'; # Test a lexical variable. |
122 | |
a687059c |
123 | format OUT2 = |
124 | the quick brown @<< |
125 | $fox |
126 | jumped |
127 | @* |
128 | $multiline |
129 | ^<<<<<<<<< ~~ |
130 | $foo |
131 | now @<<the@>>>> for all@|||||men to come @<<<< |
132 | 'i' . 's', "time\n", $good, 'to' |
133 | . |
134 | |
a0d0e21e |
135 | open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; |
a687059c |
136 | |
a687059c |
137 | $good = 'good'; |
138 | $multiline = "forescore\nand\nseven years\n"; |
139 | $foo = 'when in the course of human events it becomes necessary'; |
140 | write(OUT2); |
d1e4d418 |
141 | close OUT2 or die "Could not close: $!"; |
a687059c |
142 | |
143 | $right = |
144 | "the quick brown fox |
145 | jumped |
146 | forescore |
147 | and |
148 | seven years |
149 | when in |
150 | the course |
151 | of human |
152 | events it |
153 | becomes |
154 | necessary |
155 | now is the time for all good men to come to\n"; |
156 | |
2027357e |
157 | is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; }; |
a687059c |
158 | |
0f85fab0 |
159 | eval <<'EOFORMAT'; |
160 | format OUT2 = |
161 | the brown quick @<< |
162 | $fox |
163 | jumped |
164 | @* |
165 | $multiline |
a0d0e21e |
166 | and |
0f85fab0 |
167 | ^<<<<<<<<< ~~ |
168 | $foo |
169 | now @<<the@>>>> for all@|||||men to come @<<<< |
170 | 'i' . 's', "time\n", $good, 'to' |
171 | . |
172 | EOFORMAT |
173 | |
a0d0e21e |
174 | open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
0f85fab0 |
175 | |
176 | $fox = 'foxiness'; |
177 | $good = 'good'; |
178 | $multiline = "forescore\nand\nseven years\n"; |
179 | $foo = 'when in the course of human events it becomes necessary'; |
180 | write(OUT2); |
d1e4d418 |
181 | close OUT2 or die "Could not close: $!"; |
0f85fab0 |
182 | |
183 | $right = |
184 | "the brown quick fox |
185 | jumped |
186 | forescore |
187 | and |
188 | seven years |
a0d0e21e |
189 | and |
0f85fab0 |
190 | when in |
191 | the course |
192 | of human |
193 | events it |
194 | becomes |
195 | necessary |
196 | now is the time for all good men to come to\n"; |
197 | |
2027357e |
198 | is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; |
0f85fab0 |
199 | |
55497cff |
200 | # formline tests |
201 | |
90f67b00 |
202 | $right = <<EOT; |
55497cff |
203 | @ a |
204 | @> ab |
205 | @>> abc |
206 | @>>> abc |
207 | @>>>> abc |
208 | @>>>>> abc |
209 | @>>>>>> abc |
210 | @>>>>>>> abc |
211 | @>>>>>>>> abc |
212 | @>>>>>>>>> abc |
213 | @>>>>>>>>>> abc |
214 | EOT |
215 | |
90f67b00 |
216 | my $was1 = my $was2 = ''; |
217 | use vars '$format2'; |
55497cff |
218 | for (0..10) { |
219 | # lexical picture |
220 | $^A = ''; |
221 | my $format1 = '@' . '>' x $_; |
222 | formline $format1, 'abc'; |
223 | $was1 .= "$format1 $^A\n"; |
224 | # global |
225 | $^A = ''; |
226 | local $format2 = '@' . '>' x $_; |
227 | formline $format2, 'abc'; |
228 | $was2 .= "$format2 $^A\n"; |
229 | } |
90f67b00 |
230 | is $was1, $right; |
231 | is $was2, $right; |
55497cff |
232 | |
7056ecde |
233 | $^A = ''; |
234 | |
235 | # more test |
236 | |
237 | format OUT3 = |
238 | ^<<<<<<... |
239 | $foo |
240 | . |
241 | |
242 | open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
243 | |
244 | $foo = 'fit '; |
245 | write(OUT3); |
d1e4d418 |
246 | close OUT3 or die "Could not close: $!"; |
7056ecde |
247 | |
248 | $right = |
249 | "fit\n"; |
250 | |
2027357e |
251 | is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; |
252 | |
7056ecde |
253 | |
445b3f51 |
254 | # test lexicals and globals |
255 | { |
2027357e |
256 | my $test = curr_test(); |
445b3f51 |
257 | my $this = "ok"; |
2027357e |
258 | our $that = $test; |
445b3f51 |
259 | format LEX = |
260 | @<<@| |
261 | $this,$that |
262 | . |
263 | open(LEX, ">&STDOUT") or die; |
264 | write LEX; |
2027357e |
265 | $that = ++$test; |
445b3f51 |
266 | write LEX; |
d1e4d418 |
267 | close LEX or die "Could not close: $!"; |
2027357e |
268 | curr_test($test + 1); |
445b3f51 |
269 | } |
c2e66d9e |
270 | # LEX_INTERPNORMAL test |
271 | my %e = ( a => 1 ); |
272 | format OUT4 = |
273 | @<<<<<< |
274 | "$e{a}" |
275 | . |
276 | open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; |
277 | write (OUT4); |
d1e4d418 |
278 | close OUT4 or die "Could not close: $!"; |
2027357e |
279 | is cat('Op_write.tmp'), "1\n" and do { 1 while unlink "Op_write.tmp" }; |
784707d5 |
280 | |
281 | eval <<'EOFORMAT'; |
282 | format OUT10 = |
283 | @####.## @0###.## |
284 | $test1, $test1 |
285 | . |
286 | EOFORMAT |
287 | |
288 | open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
289 | |
90f67b00 |
290 | use vars '$test1'; |
784707d5 |
291 | $test1 = 12.95; |
292 | write(OUT10); |
d1e4d418 |
293 | close OUT10 or die "Could not close: $!"; |
784707d5 |
294 | |
295 | $right = " 12.95 00012.95\n"; |
2027357e |
296 | is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; |
784707d5 |
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"; |
2027357e |
319 | is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; |
9ccde9ea |
320 | |
31869a79 |
321 | { |
2027357e |
322 | my $test = curr_test(); |
71f882da |
323 | my $el; |
a1b95068 |
324 | format OUT12 = |
31869a79 |
325 | ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze |
326 | $el |
327 | . |
2027357e |
328 | my %hash = ($test => 3); |
a1b95068 |
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 |
334 | close OUT12 or die "Could not close: $!"; |
a344b90b |
335 | print cat('Op_write.tmp'); |
2027357e |
336 | curr_test($test + 1); |
31869a79 |
337 | } |
338 | |
ea42cebc |
339 | { |
2027357e |
340 | my $test = curr_test(); |
ea42cebc |
341 | # Bug report and testcase by Alexey Tourbin |
342 | use Tie::Scalar; |
343 | my $v; |
344 | tie $v, 'Tie::StdScalar'; |
2027357e |
345 | $v = $test; |
ea42cebc |
346 | format OUT13 = |
347 | ok ^<<<<<<<<< ~~ |
348 | $v |
349 | . |
350 | open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
351 | write(OUT13); |
352 | close OUT13 or die "Could not close: $!"; |
a344b90b |
353 | print cat('Op_write.tmp'); |
2027357e |
354 | curr_test($test + 1); |
ea42cebc |
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"; |
2027357e |
362 | like $@, qr/Format not terminated/; |
f5c235e7 |
363 | } |
364 | |
a1b95068 |
365 | { # test 15 |
366 | # text lost in ^<<< field with \r in value (WL) |
367 | my $txt = "line 1\rline 2"; |
368 | format OUT15 = |
369 | ^<<<<<<<<<<<<<<<<<< |
370 | $txt |
371 | ^<<<<<<<<<<<<<<<<<< |
372 | $txt |
373 | . |
374 | open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
375 | write(OUT15); |
376 | close OUT15 or die "Could not close: $!"; |
a344b90b |
377 | my $res = cat('Op_write.tmp'); |
2027357e |
378 | is $res, "line 1\nline 2\n"; |
a1b95068 |
379 | } |
380 | |
381 | { # test 16: multiple use of a variable in same line with ^< |
382 | my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; |
383 | format OUT16 = |
384 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< |
385 | $txt, $txt |
386 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< |
387 | $txt, $txt |
388 | . |
389 | open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
390 | write(OUT16); |
391 | close OUT16 or die "Could not close: $!"; |
a344b90b |
392 | my $res = cat('Op_write.tmp'); |
2027357e |
393 | is $res, <<EOD; |
a1b95068 |
394 | this_is_block_1 this_is_block_2 |
395 | this_is_block_3 this_is_block_4 |
396 | EOD |
397 | } |
398 | |
399 | { # test 17: @* "should be on a line of its own", but it should work |
400 | # cleanly with literals before and after. (WL) |
401 | |
402 | my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; |
403 | format OUT17 = |
404 | Here we go: @* That's all, folks! |
405 | $txt |
406 | . |
407 | open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
408 | write(OUT17); |
409 | close OUT17 or die "Could not close: $!"; |
a344b90b |
410 | my $res = cat('Op_write.tmp'); |
a1b95068 |
411 | chomp( $txt ); |
412 | my $exp = <<EOD; |
413 | Here we go: $txt That's all, folks! |
414 | EOD |
2027357e |
415 | is $res, $exp; |
a1b95068 |
416 | } |
417 | |
418 | { # test 18: @# and ~~ would cause runaway format, but we now |
419 | # catch this while compiling (WL) |
420 | |
421 | format OUT18 = |
422 | @######## ~~ |
423 | 10 |
424 | . |
425 | open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
426 | eval { write(OUT18); }; |
2027357e |
427 | like $@, qr/Repeated format line will never terminate/; |
a1b95068 |
428 | close OUT18 or die "Could not close: $!"; |
429 | } |
430 | |
431 | { # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) |
432 | my $v = 'gaga'; |
433 | eval "format OUT19 = \n" . |
434 | '@<<<' . "\0\n" . |
435 | '$v' . "\n" . |
436 | '@<<<' . "\0\n" . |
437 | '$v' . "\n.\n"; |
438 | open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
439 | write(OUT19); |
a344b90b |
440 | close OUT19 or die "Could not close: $!"; |
441 | my $res = cat('Op_write.tmp'); |
2027357e |
442 | is $res, <<EOD; |
a1b95068 |
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); |
a344b90b |
469 | close OUT20 or die "Could not close: $!"; |
470 | my $res = cat('Op_write.tmp'); |
2027357e |
471 | is $res, $exp; |
a1b95068 |
472 | } |
473 | |
474 | |
475 | ##################### |
476 | ## Section 2 |
477 | ## numeric formatting |
478 | ##################### |
479 | |
2027357e |
480 | curr_test($bas_tests + 1); |
481 | |
a1b95068 |
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 ); |
2027357e |
488 | if (ref $expected) { |
489 | like $writeres, $expected, $writefmt; |
490 | } else { |
491 | is $writeres, $expected, $writefmt; |
492 | } |
a1b95068 |
493 | } |
494 | } |
495 | |
496 | |
497 | ##################################### |
498 | ## Section 3 |
f5b75c1c |
499 | ## Easiest to add new tests just here |
2027357e |
500 | ##################################### |
9ccde9ea |
501 | |
30a1e583 |
502 | # DAPM. Exercise a couple of error codepaths |
503 | |
504 | { |
505 | local $~ = ''; |
506 | eval { write }; |
6108250c |
507 | like $@, qr/Not a format reference/, 'format reference'; |
30a1e583 |
508 | |
509 | $~ = "NOSUCHFORMAT"; |
510 | eval { write }; |
6108250c |
511 | like $@, qr/Undefined format/, 'no such format'; |
30a1e583 |
512 | } |
513 | |
f3f2f1a3 |
514 | { |
e8e72d41 |
515 | package Count; |
516 | |
517 | sub TIESCALAR { |
518 | my $class = shift; |
519 | bless [shift, 0, 0], $class; |
520 | } |
521 | |
522 | sub FETCH { |
523 | my $self = shift; |
524 | ++$self->[1]; |
525 | $self->[0]; |
526 | } |
527 | |
528 | sub STORE { |
529 | my $self = shift; |
530 | ++$self->[2]; |
531 | $self->[0] = shift; |
532 | } |
533 | } |
534 | |
535 | { |
536 | my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a} |
f3f2f1a3 |
537 | my ($pound, $pm) = ("\xA3", "\xB1"); |
538 | |
539 | foreach my $first ('N', $pound, $pound_utf8) { |
540 | foreach my $base ('N', $pm, $pm_utf8) { |
003d2c64 |
541 | foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n", |
542 | "$base\nMoo!\n",) { |
543 | foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) { |
544 | my ($format, $re) = @$_; |
e8e72d41 |
545 | foreach my $class ('', 'Count') { |
546 | my $name = "$first, $second $format $class"; |
547 | $name =~ s/\n/\\n/g; |
548 | |
549 | $first =~ /(.+)/ or die $first; |
550 | my $expect = "1${1}2"; |
551 | $second =~ $re or die $second; |
552 | $expect .= " 3${1}4"; |
553 | |
554 | if ($class) { |
555 | my $copy1 = $first; |
556 | my $copy2; |
557 | tie $copy2, $class, $second; |
558 | is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name; |
559 | my $obj = tied $copy2; |
560 | is $obj->[1], 1, 'value read exactly once'; |
561 | } else { |
562 | my ($copy1, $copy2) = ($first, $second); |
563 | is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name; |
564 | } |
565 | } |
003d2c64 |
566 | } |
f3f2f1a3 |
567 | } |
568 | } |
569 | } |
570 | } |
9ccde9ea |
571 | |
35c6393c |
572 | { |
573 | # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because |
574 | # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will |
575 | # be doing something similarly out of bounds on everything from 5.000 |
576 | my $ref = []; |
577 | is swrite('>^*<', $ref), ">$ref<"; |
578 | is swrite('>@*<', $ref), ">$ref<"; |
579 | } |
580 | |
d57f9278 |
581 | format EMPTY = |
582 | . |
583 | |
f5b75c1c |
584 | my $test = curr_test(); |
6108250c |
585 | |
d57f9278 |
586 | format Comment = |
587 | ok @<<<<< |
588 | $test |
589 | . |
590 | |
d57f9278 |
591 | |
592 | # [ID 20020227.005] format bug with undefined _TOP |
0bd0581c |
593 | |
594 | open STDOUT_DUP, ">&STDOUT"; |
595 | my $oldfh = select STDOUT_DUP; |
596 | $= = 10; |
6108250c |
597 | { |
598 | local $~ = "Comment"; |
599 | write; |
600 | curr_test($test + 1); |
601 | { |
602 | local $::TODO = '[ID 20020227.005] format bug with undefined _TOP'; |
603 | is $-, 9; |
604 | } |
605 | is $^, "STDOUT_DUP_TOP"; |
0bd0581c |
606 | } |
607 | select $oldfh; |
68ba3c2c |
608 | close STDOUT_DUP; |
d57f9278 |
609 | |
2027357e |
610 | ############################# |
611 | ## Section 4 |
612 | ## Add new tests *above* here |
613 | ############################# |
614 | |
f5b75c1c |
615 | # scary format testing from H.Merijn Brand |
616 | |
617 | # Just a complete test for format, including top-, left- and bottom marging |
618 | # and format detection through glob entries |
619 | |
2027357e |
620 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' || |
f5b75c1c |
621 | ($^O eq 'os2' and not eval '$OS2::can_fork')) { |
622 | $test = curr_test(); |
623 | SKIP: { |
624 | skip "'|-' and '-|' not supported", $tests - $test + 1; |
625 | } |
626 | exit(0); |
627 | } |
628 | |
629 | |
0bd0581c |
630 | $^ = "STDOUT_TOP"; |
631 | $= = 7; # Page length |
632 | $- = 0; # Lines left |
9ccde9ea |
633 | my $ps = $^L; $^L = ""; # Catch the page separator |
634 | my $tm = 1; # Top margin (empty lines before first output) |
635 | my $bm = 2; # Bottom marging (empty lines between last text and footer) |
636 | my $lm = 4; # Left margin (indent in spaces) |
637 | |
68ba3c2c |
638 | # ----------------------------------------------------------------------- |
639 | # |
640 | # execute the rest of the script in a child process. The parent reads the |
641 | # output from the child and compares it with <DATA>. |
642 | |
643 | my @data = <DATA>; |
644 | |
645 | select ((select (STDOUT), $| = 1)[0]); # flush STDOUT |
646 | |
647 | my $opened = open FROM_CHILD, "-|"; |
648 | unless (defined $opened) { |
6108250c |
649 | fail "open gave $!"; |
650 | exit 0; |
68ba3c2c |
651 | } |
652 | |
653 | if ($opened) { |
654 | # in parent here |
655 | |
6108250c |
656 | pass 'open'; |
9ccde9ea |
657 | my $s = " " x $lm; |
68ba3c2c |
658 | while (<FROM_CHILD>) { |
659 | unless (@data) { |
6108250c |
660 | fail 'too much output'; |
68ba3c2c |
661 | exit; |
662 | } |
9ccde9ea |
663 | s/^/$s/; |
68ba3c2c |
664 | my $exp = shift @data; |
6108250c |
665 | is $_, $exp; |
9ccde9ea |
666 | } |
68ba3c2c |
667 | close FROM_CHILD; |
6108250c |
668 | is "@data", "", "correct length of output"; |
68ba3c2c |
669 | exit; |
670 | } |
671 | |
672 | # in child here |
6108250c |
673 | $::NO_ENDING = 1; |
68ba3c2c |
674 | |
675 | select ((select (STDOUT), $| = 1)[0]); |
9ccde9ea |
676 | $tm = "\n" x $tm; |
677 | $= -= $bm + 1; # count one for the trailing "----" |
678 | my $lastmin = 0; |
679 | |
680 | my @E; |
681 | |
682 | sub wryte |
683 | { |
684 | $lastmin = $-; |
685 | write; |
686 | } # wryte; |
687 | |
688 | sub footer |
689 | { |
690 | $% == 1 and return ""; |
691 | |
692 | $lastmin < $= and print "\n" x $lastmin; |
693 | print "\n" x $bm, "----\n", $ps; |
694 | $lastmin = $-; |
695 | ""; |
696 | } # footer |
697 | |
698 | # Yes, this is sick ;-) |
699 | format TOP = |
700 | @* ~ |
701 | @{[footer]} |
702 | @* ~ |
703 | $tm |
704 | . |
705 | |
9ccde9ea |
706 | format ENTRY = |
707 | @ @<<<<~~ |
708 | @{(shift @E)||["",""]} |
709 | . |
710 | |
711 | format EOR = |
712 | - ----- |
713 | . |
714 | |
715 | sub has_format ($) |
716 | { |
717 | my $fmt = shift; |
718 | exists $::{$fmt} or return 0; |
719 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; |
720 | open my $null, "> /dev/null" or die; |
721 | my $fh = select $null; |
722 | local $~ = $fmt; |
723 | eval "write"; |
724 | select $fh; |
725 | $@?0:1; |
726 | } # has_format |
727 | |
d57f9278 |
728 | $^ = has_format ("TOP") ? "TOP" : "EMPTY"; |
9ccde9ea |
729 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
730 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], |
731 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { |
732 | @E = @$e; |
733 | local $~ = "ENTRY"; |
734 | wryte; |
735 | has_format ("EOR") or next; |
736 | local $~ = "EOR"; |
737 | wryte; |
738 | } |
739 | if (has_format ("EOF")) { |
740 | local $~ = "EOF"; |
741 | wryte; |
742 | } |
743 | |
744 | close STDOUT; |
745 | |
ea42cebc |
746 | # That was test 48. |
9ccde9ea |
747 | |
748 | __END__ |
749 | |
750 | 1 Test1 |
751 | 2 Test2 |
752 | 3 Test3 |
753 | |
754 | |
755 | ---- |
756 | \f |
757 | 4 Test4 |
758 | 5 Test5 |
759 | 6 Test6 |
760 | |
761 | |
762 | ---- |
763 | \f |
764 | 7 Test7 |
765 | - ----- |
766 | |
767 | |
768 | |
769 | ---- |
770 | \f |
771 | 1 1tseT |
772 | 2 2tseT |
773 | 3 3tseT |
774 | |
775 | |
776 | ---- |
777 | \f |
778 | 4 4tseT |
779 | 5 5tseT |
780 | - ----- |