Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
9ccde9ea JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6108250c | 6 | require './test.pl'; |
9ccde9ea JH |
7 | } |
8 | ||
90f67b00 NC |
9 | use strict; # Amazed that this hackery can be made strict ... |
10 | ||
a344b90b DM |
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 WL |
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 DM |
32 | [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', |
33 | 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], | |
d1f6232e | 34 | |
9acd3e2c DM |
35 | [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', |
36 | -999.4999, '-999', -999.6, '####', 1e+100, '####' ], | |
d1f6232e DM |
37 | |
38 | [ '^###', 0, ' 0', undef, ' ' ], | |
39 | ||
40 | [ '^0##', 0, '0000', undef, ' ' ], | |
41 | ||
9acd3e2c DM |
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 DM |
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 DM |
50 | |
51 | ); | |
52 | ||
a1b95068 WL |
53 | |
54 | my $num_tests = 0; | |
55 | for my $tref ( @NumTests ){ | |
d1f6232e | 56 | $num_tests += (@$tref - 1)/2; |
a1b95068 WL |
57 | } |
58 | #--------------------------------------------------------- | |
59 | ||
60 | # number of tests in section 1 | |
b27dce25 | 61 | my $bas_tests = 21; |
a1b95068 WL |
62 | |
63 | # number of tests in section 3 | |
7c93c29b | 64 | my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 11; |
a1b95068 | 65 | |
f5b75c1c NC |
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 NC |
70 | |
71 | plan $tests; | |
a687059c | 72 | |
a1b95068 WL |
73 | ############ |
74 | ## Section 1 | |
75 | ############ | |
76 | ||
90f67b00 NC |
77 | use vars qw($fox $multiline $foo $good); |
78 | ||
a687059c LW |
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 LW |
92 | { |
93 | 'i' . 's', "time\n", $good, 'to' | |
94 | } | |
a687059c LW |
95 | . |
96 | ||
a0d0e21e | 97 | open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
951af6b5 | 98 | END { unlink_all 'Op_write.tmp' } |
a687059c LW |
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 LW |
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 | ||
951af6b5 | 118 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
a687059c | 119 | |
748a9306 LW |
120 | $fox = 'wolfishness'; |
121 | my $fox = 'foxiness'; # Test a lexical variable. | |
122 | ||
a687059c LW |
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 LW |
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 LW |
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 | ||
951af6b5 | 157 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
a687059c | 158 | |
0f85fab0 LW |
159 | eval <<'EOFORMAT'; |
160 | format OUT2 = | |
161 | the brown quick @<< | |
162 | $fox | |
163 | jumped | |
164 | @* | |
165 | $multiline | |
a0d0e21e | 166 | and |
0f85fab0 LW |
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 LW |
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 LW |
182 | |
183 | $right = | |
184 | "the brown quick fox | |
185 | jumped | |
186 | forescore | |
187 | and | |
188 | seven years | |
a0d0e21e | 189 | and |
0f85fab0 LW |
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 | ||
951af6b5 | 198 | is cat('Op_write.tmp'), $right and unlink_all '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 NC |
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 NC |
230 | is $was1, $right; |
231 | is $was2, $right; | |
55497cff | 232 | |
7056ecde KM |
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 KM |
247 | |
248 | $right = | |
249 | "fit\n"; | |
250 | ||
951af6b5 | 251 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
2027357e | 252 | |
7056ecde | 253 | |
445b3f51 GS |
254 | # test lexicals and globals |
255 | { | |
2027357e | 256 | my $test = curr_test(); |
445b3f51 | 257 | my $this = "ok"; |
2027357e | 258 | our $that = $test; |
445b3f51 GS |
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 GS |
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: $!"; |
951af6b5 | 279 | is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp"; |
784707d5 | 280 | |
b27dce25 FC |
281 | # More LEX_INTERPNORMAL |
282 | format OUT4a= | |
283 | @<<<<<<<<<<<<<<< | |
284 | "${; use | |
285 | strict; \'Nasdaq dropping like flies'}" | |
286 | . | |
287 | open OUT4a, ">Op_write.tmp" or die "Can't create Op_write.tmp"; | |
288 | write (OUT4a); | |
289 | close OUT4a or die "Could not close: $!"; | |
290 | is cat('Op_write.tmp'), "Nasdaq dropping\n", 'skipspace inside "${...}"' | |
291 | and unlink_all "Op_write.tmp"; | |
292 | ||
784707d5 JP |
293 | eval <<'EOFORMAT'; |
294 | format OUT10 = | |
295 | @####.## @0###.## | |
296 | $test1, $test1 | |
297 | . | |
298 | EOFORMAT | |
299 | ||
300 | open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
301 | ||
90f67b00 | 302 | use vars '$test1'; |
784707d5 JP |
303 | $test1 = 12.95; |
304 | write(OUT10); | |
d1e4d418 | 305 | close OUT10 or die "Could not close: $!"; |
784707d5 JP |
306 | |
307 | $right = " 12.95 00012.95\n"; | |
951af6b5 | 308 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
784707d5 JP |
309 | |
310 | eval <<'EOFORMAT'; | |
311 | format OUT11 = | |
312 | @0###.## | |
313 | $test1 | |
314 | @ 0# | |
315 | $test1 | |
316 | @0 # | |
317 | $test1 | |
318 | . | |
319 | EOFORMAT | |
320 | ||
321 | open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
322 | ||
323 | $test1 = 12.95; | |
324 | write(OUT11); | |
d1e4d418 | 325 | close OUT11 or die "Could not close: $!"; |
784707d5 JP |
326 | |
327 | $right = | |
328 | "00012.95 | |
329 | 1 0# | |
330 | 10 #\n"; | |
951af6b5 | 331 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
9ccde9ea | 332 | |
31869a79 | 333 | { |
2027357e | 334 | my $test = curr_test(); |
71f882da | 335 | my $el; |
a1b95068 | 336 | format OUT12 = |
31869a79 AE |
337 | ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze |
338 | $el | |
339 | . | |
2027357e | 340 | my %hash = ($test => 3); |
a1b95068 WL |
341 | open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
342 | ||
31869a79 | 343 | for $el (keys %hash) { |
a1b95068 | 344 | write(OUT12); |
31869a79 | 345 | } |
a1b95068 | 346 | close OUT12 or die "Could not close: $!"; |
a344b90b | 347 | print cat('Op_write.tmp'); |
2027357e | 348 | curr_test($test + 1); |
31869a79 AE |
349 | } |
350 | ||
ea42cebc | 351 | { |
2027357e | 352 | my $test = curr_test(); |
ea42cebc RGS |
353 | # Bug report and testcase by Alexey Tourbin |
354 | use Tie::Scalar; | |
355 | my $v; | |
356 | tie $v, 'Tie::StdScalar'; | |
2027357e | 357 | $v = $test; |
ea42cebc RGS |
358 | format OUT13 = |
359 | ok ^<<<<<<<<< ~~ | |
360 | $v | |
361 | . | |
362 | open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
363 | write(OUT13); | |
364 | close OUT13 or die "Could not close: $!"; | |
a344b90b | 365 | print cat('Op_write.tmp'); |
2027357e | 366 | curr_test($test + 1); |
ea42cebc RGS |
367 | } |
368 | ||
a1b95068 WL |
369 | { # test 14 |
370 | # Bug #24774 format without trailing \n failed assertion, but this | |
371 | # must fail since we have a trailing ; in the eval'ed string (WL) | |
f5c235e7 DM |
372 | my @v = ('k'); |
373 | eval "format OUT14 = \n@\n\@v"; | |
2027357e | 374 | like $@, qr/Format not terminated/; |
f5c235e7 DM |
375 | } |
376 | ||
a1b95068 WL |
377 | { # test 15 |
378 | # text lost in ^<<< field with \r in value (WL) | |
379 | my $txt = "line 1\rline 2"; | |
380 | format OUT15 = | |
381 | ^<<<<<<<<<<<<<<<<<< | |
382 | $txt | |
383 | ^<<<<<<<<<<<<<<<<<< | |
384 | $txt | |
385 | . | |
386 | open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
387 | write(OUT15); | |
388 | close OUT15 or die "Could not close: $!"; | |
a344b90b | 389 | my $res = cat('Op_write.tmp'); |
2027357e | 390 | is $res, "line 1\nline 2\n"; |
a1b95068 WL |
391 | } |
392 | ||
393 | { # test 16: multiple use of a variable in same line with ^< | |
394 | my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; | |
395 | format OUT16 = | |
396 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< | |
397 | $txt, $txt | |
398 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< | |
399 | $txt, $txt | |
400 | . | |
401 | open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
402 | write(OUT16); | |
403 | close OUT16 or die "Could not close: $!"; | |
a344b90b | 404 | my $res = cat('Op_write.tmp'); |
2027357e | 405 | is $res, <<EOD; |
a1b95068 WL |
406 | this_is_block_1 this_is_block_2 |
407 | this_is_block_3 this_is_block_4 | |
408 | EOD | |
409 | } | |
410 | ||
411 | { # test 17: @* "should be on a line of its own", but it should work | |
412 | # cleanly with literals before and after. (WL) | |
413 | ||
414 | my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; | |
415 | format OUT17 = | |
416 | Here we go: @* That's all, folks! | |
417 | $txt | |
418 | . | |
419 | open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
420 | write(OUT17); | |
421 | close OUT17 or die "Could not close: $!"; | |
a344b90b | 422 | my $res = cat('Op_write.tmp'); |
a1b95068 WL |
423 | chomp( $txt ); |
424 | my $exp = <<EOD; | |
425 | Here we go: $txt That's all, folks! | |
426 | EOD | |
2027357e | 427 | is $res, $exp; |
a1b95068 WL |
428 | } |
429 | ||
430 | { # test 18: @# and ~~ would cause runaway format, but we now | |
431 | # catch this while compiling (WL) | |
432 | ||
433 | format OUT18 = | |
434 | @######## ~~ | |
435 | 10 | |
436 | . | |
437 | open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
438 | eval { write(OUT18); }; | |
2027357e | 439 | like $@, qr/Repeated format line will never terminate/; |
a1b95068 WL |
440 | close OUT18 or die "Could not close: $!"; |
441 | } | |
442 | ||
443 | { # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) | |
444 | my $v = 'gaga'; | |
445 | eval "format OUT19 = \n" . | |
446 | '@<<<' . "\0\n" . | |
447 | '$v' . "\n" . | |
448 | '@<<<' . "\0\n" . | |
449 | '$v' . "\n.\n"; | |
450 | open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
451 | write(OUT19); | |
a344b90b DM |
452 | close OUT19 or die "Could not close: $!"; |
453 | my $res = cat('Op_write.tmp'); | |
2027357e | 454 | is $res, <<EOD; |
a1b95068 WL |
455 | gaga\0 |
456 | gaga\0 | |
457 | EOD | |
458 | } | |
459 | ||
460 | { # test 20: hash accesses; single '}' must not terminate format '}' (WL) | |
461 | my %h = ( xkey => 'xval', ykey => 'yval' ); | |
462 | format OUT20 = | |
463 | @>>>> @<<<< ~~ | |
464 | each %h | |
465 | @>>>> @<<<< | |
466 | $h{xkey}, $h{ykey} | |
467 | @>>>> @<<<< | |
468 | { $h{xkey}, $h{ykey} | |
469 | } | |
470 | } | |
471 | . | |
472 | my $exp = ''; | |
473 | while( my( $k, $v ) = each( %h ) ){ | |
474 | $exp .= sprintf( "%5s %s\n", $k, $v ); | |
475 | } | |
476 | $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); | |
477 | $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); | |
478 | $exp .= "}\n"; | |
479 | open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
480 | write(OUT20); | |
a344b90b DM |
481 | close OUT20 or die "Could not close: $!"; |
482 | my $res = cat('Op_write.tmp'); | |
2027357e | 483 | is $res, $exp; |
a1b95068 WL |
484 | } |
485 | ||
486 | ||
487 | ##################### | |
488 | ## Section 2 | |
489 | ## numeric formatting | |
490 | ##################### | |
491 | ||
2027357e NC |
492 | curr_test($bas_tests + 1); |
493 | ||
a1b95068 WL |
494 | for my $tref ( @NumTests ){ |
495 | my $writefmt = shift( @$tref ); | |
d1f6232e DM |
496 | while (@$tref) { |
497 | my $val = shift @$tref; | |
498 | my $expected = shift @$tref; | |
a1b95068 | 499 | my $writeres = swrite( $writefmt, $val ); |
2027357e NC |
500 | if (ref $expected) { |
501 | like $writeres, $expected, $writefmt; | |
502 | } else { | |
503 | is $writeres, $expected, $writefmt; | |
504 | } | |
a1b95068 WL |
505 | } |
506 | } | |
507 | ||
508 | ||
509 | ##################################### | |
510 | ## Section 3 | |
f5b75c1c | 511 | ## Easiest to add new tests just here |
2027357e | 512 | ##################################### |
9ccde9ea | 513 | |
30a1e583 DM |
514 | # DAPM. Exercise a couple of error codepaths |
515 | ||
516 | { | |
517 | local $~ = ''; | |
518 | eval { write }; | |
2d1ebc9b | 519 | like $@, qr/Undefined format ""/, 'format with 0-length name'; |
30a1e583 | 520 | |
44b7e78a FC |
521 | $~ = "\0foo"; |
522 | eval { write }; | |
523 | like $@, qr/Undefined format "\0foo"/, | |
524 | 'no such format beginning with null'; | |
525 | ||
30a1e583 DM |
526 | $~ = "NOSUCHFORMAT"; |
527 | eval { write }; | |
44b7e78a | 528 | like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format'; |
30a1e583 DM |
529 | } |
530 | ||
44b7e78a FC |
531 | select +(select(OUT21), do { |
532 | open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
533 | ||
534 | format OUT21 = | |
535 | @<< | |
536 | $_ | |
537 | . | |
538 | ||
539 | local $^ = ''; | |
540 | local $= = 1; | |
541 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
542 | like $@, qr/Undefined top format ""/, 'top format with 0-length name'; | |
543 | ||
544 | $^ = "\0foo"; | |
545 | # For some reason, we have to do this twice to get the error again. | |
546 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
547 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
548 | like $@, qr/Undefined top format "\0foo"/, | |
549 | 'no such top format beginning with null'; | |
550 | ||
551 | $^ = "NOSUCHFORMAT"; | |
552 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
553 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
554 | like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format'; | |
555 | ||
556 | # reset things; | |
557 | eval { write(OUT21) }; | |
558 | undef $^A; | |
559 | ||
560 | close OUT21 or die "Could not close: $!"; | |
561 | })[0]; | |
562 | ||
f3f2f1a3 | 563 | { |
e8e72d41 NC |
564 | package Count; |
565 | ||
566 | sub TIESCALAR { | |
567 | my $class = shift; | |
568 | bless [shift, 0, 0], $class; | |
569 | } | |
570 | ||
571 | sub FETCH { | |
572 | my $self = shift; | |
573 | ++$self->[1]; | |
574 | $self->[0]; | |
575 | } | |
576 | ||
577 | sub STORE { | |
578 | my $self = shift; | |
579 | ++$self->[2]; | |
580 | $self->[0] = shift; | |
581 | } | |
582 | } | |
583 | ||
584 | { | |
585 | my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a} | |
f3f2f1a3 NC |
586 | my ($pound, $pm) = ("\xA3", "\xB1"); |
587 | ||
588 | foreach my $first ('N', $pound, $pound_utf8) { | |
589 | foreach my $base ('N', $pm, $pm_utf8) { | |
003d2c64 NC |
590 | foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n", |
591 | "$base\nMoo!\n",) { | |
592 | foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) { | |
593 | my ($format, $re) = @$_; | |
b57b1734 | 594 | $format = "1^*2 3${format}4"; |
e8e72d41 | 595 | foreach my $class ('', 'Count') { |
b57b1734 | 596 | my $name = qq{swrite("$format", "$first", "$second") class="$class"}; |
e8e72d41 | 597 | $name =~ s/\n/\\n/g; |
b57b1734 DM |
598 | $name =~ s{(.)}{ |
599 | ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1 | |
600 | }ge; | |
e8e72d41 NC |
601 | |
602 | $first =~ /(.+)/ or die $first; | |
603 | my $expect = "1${1}2"; | |
604 | $second =~ $re or die $second; | |
605 | $expect .= " 3${1}4"; | |
606 | ||
607 | if ($class) { | |
608 | my $copy1 = $first; | |
609 | my $copy2; | |
610 | tie $copy2, $class, $second; | |
b57b1734 | 611 | is swrite("$format", $copy1, $copy2), $expect, $name; |
e8e72d41 NC |
612 | my $obj = tied $copy2; |
613 | is $obj->[1], 1, 'value read exactly once'; | |
614 | } else { | |
615 | my ($copy1, $copy2) = ($first, $second); | |
b57b1734 | 616 | is swrite("$format", $copy1, $copy2), $expect, $name; |
e8e72d41 NC |
617 | } |
618 | } | |
003d2c64 | 619 | } |
f3f2f1a3 NC |
620 | } |
621 | } | |
622 | } | |
623 | } | |
9ccde9ea | 624 | |
35c6393c NC |
625 | { |
626 | # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because | |
627 | # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will | |
628 | # be doing something similarly out of bounds on everything from 5.000 | |
629 | my $ref = []; | |
630 | is swrite('>^*<', $ref), ">$ref<"; | |
631 | is swrite('>@*<', $ref), ">$ref<"; | |
632 | } | |
633 | ||
d57f9278 MB |
634 | format EMPTY = |
635 | . | |
636 | ||
f5b75c1c | 637 | my $test = curr_test(); |
6108250c | 638 | |
d57f9278 MB |
639 | format Comment = |
640 | ok @<<<<< | |
641 | $test | |
642 | . | |
643 | ||
d57f9278 | 644 | |
64eff8b7 | 645 | # RT #8698 format bug with undefined _TOP |
0bd0581c DM |
646 | |
647 | open STDOUT_DUP, ">&STDOUT"; | |
648 | my $oldfh = select STDOUT_DUP; | |
649 | $= = 10; | |
6108250c NC |
650 | { |
651 | local $~ = "Comment"; | |
652 | write; | |
653 | curr_test($test + 1); | |
64eff8b7 | 654 | is $-, 9; |
6108250c | 655 | is $^, "STDOUT_DUP_TOP"; |
0bd0581c DM |
656 | } |
657 | select $oldfh; | |
68ba3c2c | 658 | close STDOUT_DUP; |
d57f9278 | 659 | |
ef595a33 MB |
660 | *CmT = *{$::{Comment}}{FORMAT}; |
661 | ok defined *{$::{CmT}}{FORMAT}, "glob assign"; | |
662 | ||
3808a683 DM |
663 | |
664 | # RT #91032: Check that "non-real" strings like tie and overload work, | |
665 | # especially that they re-compile the pattern on each FETCH, and that | |
666 | # they don't overrun the buffer | |
667 | ||
668 | ||
669 | { | |
670 | package RT91032; | |
671 | ||
672 | sub TIESCALAR { bless [] } | |
673 | my $i = 0; | |
674 | sub FETCH { $i++; "A$i @> Z\n" } | |
675 | ||
676 | use overload '""' => \&FETCH; | |
677 | ||
678 | tie my $f, 'RT91032'; | |
679 | ||
680 | formline $f, "a"; | |
681 | formline $f, "bc"; | |
682 | ::is $^A, "A1 a Z\nA2 bc Z\n", "RT 91032: tied"; | |
683 | $^A = ''; | |
684 | ||
685 | my $g = bless []; # has overloaded stringify | |
686 | formline $g, "de"; | |
687 | formline $g, "f"; | |
688 | ::is $^A, "A3 de Z\nA4 f Z\n", "RT 91032: overloaded"; | |
689 | $^A = ''; | |
690 | ||
691 | my $h = []; | |
692 | formline $h, "junk1"; | |
693 | formline $h, "junk2"; | |
694 | ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref"; | |
695 | ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok"; | |
696 | ::is $^A, "$h$h","RT 91032: stringified array"; | |
697 | $^A = ''; | |
698 | ||
699 | # used to overwrite the ~~ in the *original SV with spaces. Naughty! | |
700 | ||
701 | my $orig = my $format = "^<<<<< ~~\n"; | |
702 | my $abc = "abc"; | |
703 | formline $format, $abc; | |
704 | $^A =''; | |
705 | ::is $format, $orig, "RT91032: don't overwrite orig format string"; | |
706 | ||
b57b1734 DM |
707 | # check that ~ and ~~ are displayed correctly as whitespace, |
708 | # under the influence of various different types of border | |
709 | ||
710 | for my $n (1,2) { | |
711 | for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') { | |
712 | for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') { | |
713 | my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n"; | |
714 | my $sfmt = ($fmt =~ s/~/ /gr); | |
715 | my ($a, $bc, $stop); | |
716 | ($a, $bc, $stop) = ('a', 'bc', 's'); | |
717 | # $stop is to stop '~~' deleting the whole line | |
718 | formline $sfmt, $stop, $a, $bc; | |
719 | my $exp = $^A; | |
720 | $^A = ''; | |
721 | ($a, $bc, $stop) = ('a', 'bc', 's'); | |
722 | formline $fmt, $stop, $a, $bc; | |
723 | my $got = $^A; | |
724 | $^A = ''; | |
725 | $fmt =~ s/\n/\\n/; | |
726 | ::is($got, $exp, "chop munging: [$fmt]"); | |
727 | } | |
728 | } | |
729 | } | |
3808a683 DM |
730 | } |
731 | ||
f5ada144 DM |
732 | # check that '~ (delete current line if empty) works when |
733 | # the target gets upgraded to uft8 (and re-allocated) midstream. | |
734 | ||
735 | { | |
736 | my $format = "\x{100}@~\n"; # format is utf8 | |
737 | # this target is not utf8, but will expand (and get reallocated) | |
738 | # when upgraded to utf8. | |
739 | my $orig = "\x80\x81\x82"; | |
740 | local $^A = $orig; | |
741 | my $empty = ""; | |
742 | formline $format, $empty; | |
743 | is $^A , $orig, "~ and realloc"; | |
744 | ||
745 | # check similarly that trailing blank removal works ok | |
746 | ||
747 | $format = "@<\n\x{100}"; # format is utf8 | |
748 | chop $format; | |
749 | $orig = " "; | |
750 | $^A = $orig; | |
751 | formline $format, " "; | |
752 | is $^A, "$orig\n", "end-of-line blanks and realloc"; | |
26e935cf DM |
753 | |
754 | # and check this doesn't overflow the buffer | |
755 | ||
756 | local $^A = ''; | |
757 | $format = "@* @####\n"; | |
758 | $orig = "x" x 100 . "\n"; | |
759 | formline $format, $orig, 12345; | |
760 | is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow"; | |
76912796 DM |
761 | |
762 | # make sure it can cope with formats > 64k | |
763 | ||
764 | $format = 'x' x 65537; | |
765 | $^A = ''; | |
766 | formline $format; | |
767 | # don't use 'is' here, as the diag output will be too long! | |
768 | ok $^A eq $format, ">64K"; | |
f5ada144 DM |
769 | } |
770 | ||
3808a683 | 771 | |
d3d1232e NC |
772 | SKIP: { |
773 | skip_if_miniperl('miniperl does not support scalario'); | |
60fe2d11 | 774 | my $buf = ""; |
fda0c190 MB |
775 | open my $fh, ">", \$buf; |
776 | my $old_fh = select $fh; | |
777 | local $~ = "CmT"; | |
778 | write; | |
779 | select $old_fh; | |
780 | close $fh; | |
781 | is $buf, "ok $test\n", "write to duplicated format"; | |
782 | } | |
783 | ||
64eff8b7 DM |
784 | format caret_A_test_TOP = |
785 | T | |
786 | . | |
787 | ||
788 | format caret_A_test = | |
789 | L1 | |
790 | L2 | |
791 | L3 | |
792 | L4 | |
793 | . | |
794 | ||
795 | SKIP: { | |
796 | skip_if_miniperl('miniperl does not support scalario'); | |
797 | my $buf = ""; | |
798 | open my $fh, ">", \$buf; | |
799 | my $old_fh = select $fh; | |
800 | local $^ = "caret_A_test_TOP"; | |
801 | local $~ = "caret_A_test"; | |
802 | local $= = 3; | |
803 | local $^A = "A1\nA2\nA3\nA4\n"; | |
804 | write; | |
805 | select $old_fh; | |
806 | close $fh; | |
807 | is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n", | |
808 | "assign to ^A sets FmLINES"; | |
809 | } | |
810 | ||
ee6d2783 NC |
811 | fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings'); |
812 | #!./perl | |
813 | ||
814 | use strict; | |
815 | use warnings; # crashes! | |
816 | ||
817 | format = | |
818 | . | |
819 | ||
820 | write; | |
821 | ||
822 | format = | |
823 | . | |
824 | ||
825 | write; | |
826 | EOP | |
827 | ||
37ffbfcc NC |
828 | fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments'); |
829 | use strict; | |
830 | use warnings; | |
831 | my $zamm = ['crunch_eth']; | |
832 | formline $zamm; | |
833 | printf ">%s<\n", ref $zamm; | |
834 | print "$zamm->[0]\n"; | |
835 | EOP | |
836 | ||
8e4ecf23 JL |
837 | # [perl #73690] |
838 | ||
839 | select +(select(RT73690), do { | |
840 | open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
841 | format RT73690 = | |
842 | @<< @<< | |
843 | 11, 22 | |
844 | . | |
845 | ||
846 | my @ret; | |
591097e0 | 847 | |
8e4ecf23 JL |
848 | @ret = write; |
849 | is(scalar(@ret), 1); | |
850 | ok($ret[0]); | |
851 | @ret = scalar(write); | |
852 | is(scalar(@ret), 1); | |
853 | ok($ret[0]); | |
854 | @ret = write(RT73690); | |
855 | is(scalar(@ret), 1); | |
856 | ok($ret[0]); | |
857 | @ret = scalar(write(RT73690)); | |
858 | is(scalar(@ret), 1); | |
859 | ok($ret[0]); | |
860 | ||
591097e0 JL |
861 | @ret = ('a', write, 'z'); |
862 | is(scalar(@ret), 3); | |
863 | is($ret[0], 'a'); | |
864 | ok($ret[1]); | |
865 | is($ret[2], 'z'); | |
866 | @ret = ('b', scalar(write), 'y'); | |
867 | is(scalar(@ret), 3); | |
868 | is($ret[0], 'b'); | |
869 | ok($ret[1]); | |
870 | is($ret[2], 'y'); | |
871 | @ret = ('c', write(RT73690), 'x'); | |
872 | is(scalar(@ret), 3); | |
873 | is($ret[0], 'c'); | |
874 | ok($ret[1]); | |
875 | is($ret[2], 'x'); | |
876 | @ret = ('d', scalar(write(RT73690)), 'w'); | |
877 | is(scalar(@ret), 3); | |
878 | is($ret[0], 'd'); | |
879 | ok($ret[1]); | |
880 | is($ret[2], 'w'); | |
881 | ||
882 | @ret = do { write; 'foo' }; | |
883 | is(scalar(@ret), 1); | |
884 | is($ret[0], 'foo'); | |
885 | @ret = do { scalar(write); 'bar' }; | |
886 | is(scalar(@ret), 1); | |
887 | is($ret[0], 'bar'); | |
888 | @ret = do { write(RT73690); 'baz' }; | |
889 | is(scalar(@ret), 1); | |
890 | is($ret[0], 'baz'); | |
891 | @ret = do { scalar(write(RT73690)); 'quux' }; | |
892 | is(scalar(@ret), 1); | |
893 | is($ret[0], 'quux'); | |
894 | ||
895 | @ret = ('a', do { write; 'foo' }, 'z'); | |
896 | is(scalar(@ret), 3); | |
897 | is($ret[0], 'a'); | |
898 | is($ret[1], 'foo'); | |
899 | is($ret[2], 'z'); | |
900 | @ret = ('b', do { scalar(write); 'bar' }, 'y'); | |
901 | is(scalar(@ret), 3); | |
902 | is($ret[0], 'b'); | |
903 | is($ret[1], 'bar'); | |
904 | is($ret[2], 'y'); | |
905 | @ret = ('c', do { write(RT73690); 'baz' }, 'x'); | |
906 | is(scalar(@ret), 3); | |
907 | is($ret[0], 'c'); | |
908 | is($ret[1], 'baz'); | |
909 | is($ret[2], 'x'); | |
910 | @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w'); | |
911 | is(scalar(@ret), 3); | |
912 | is($ret[0], 'd'); | |
913 | is($ret[1], 'quux'); | |
914 | is($ret[2], 'w'); | |
915 | ||
8e4ecf23 JL |
916 | close RT73690 or die "Could not close: $!"; |
917 | })[0]; | |
918 | ||
919 | select +(select(RT73690_2), do { | |
920 | open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
921 | format RT73690_2 = | |
922 | @<< @<< | |
923 | return | |
924 | . | |
925 | ||
926 | my @ret; | |
591097e0 | 927 | |
8e4ecf23 JL |
928 | @ret = write; |
929 | is(scalar(@ret), 1); | |
930 | ok(!$ret[0]); | |
931 | @ret = scalar(write); | |
932 | is(scalar(@ret), 1); | |
933 | ok(!$ret[0]); | |
934 | @ret = write(RT73690_2); | |
935 | is(scalar(@ret), 1); | |
936 | ok(!$ret[0]); | |
937 | @ret = scalar(write(RT73690_2)); | |
938 | is(scalar(@ret), 1); | |
939 | ok(!$ret[0]); | |
940 | ||
591097e0 JL |
941 | @ret = ('a', write, 'z'); |
942 | is(scalar(@ret), 3); | |
943 | is($ret[0], 'a'); | |
944 | ok(!$ret[1]); | |
945 | is($ret[2], 'z'); | |
946 | @ret = ('b', scalar(write), 'y'); | |
947 | is(scalar(@ret), 3); | |
948 | is($ret[0], 'b'); | |
949 | ok(!$ret[1]); | |
950 | is($ret[2], 'y'); | |
951 | @ret = ('c', write(RT73690_2), 'x'); | |
952 | is(scalar(@ret), 3); | |
953 | is($ret[0], 'c'); | |
954 | ok(!$ret[1]); | |
955 | is($ret[2], 'x'); | |
956 | @ret = ('d', scalar(write(RT73690_2)), 'w'); | |
957 | is(scalar(@ret), 3); | |
958 | is($ret[0], 'd'); | |
959 | ok(!$ret[1]); | |
960 | is($ret[2], 'w'); | |
961 | ||
962 | @ret = do { write; 'foo' }; | |
963 | is(scalar(@ret), 1); | |
964 | is($ret[0], 'foo'); | |
965 | @ret = do { scalar(write); 'bar' }; | |
966 | is(scalar(@ret), 1); | |
967 | is($ret[0], 'bar'); | |
968 | @ret = do { write(RT73690_2); 'baz' }; | |
969 | is(scalar(@ret), 1); | |
970 | is($ret[0], 'baz'); | |
971 | @ret = do { scalar(write(RT73690_2)); 'quux' }; | |
972 | is(scalar(@ret), 1); | |
973 | is($ret[0], 'quux'); | |
974 | ||
975 | @ret = ('a', do { write; 'foo' }, 'z'); | |
976 | is(scalar(@ret), 3); | |
977 | is($ret[0], 'a'); | |
978 | is($ret[1], 'foo'); | |
979 | is($ret[2], 'z'); | |
980 | @ret = ('b', do { scalar(write); 'bar' }, 'y'); | |
981 | is(scalar(@ret), 3); | |
982 | is($ret[0], 'b'); | |
983 | is($ret[1], 'bar'); | |
984 | is($ret[2], 'y'); | |
985 | @ret = ('c', do { write(RT73690_2); 'baz' }, 'x'); | |
986 | is(scalar(@ret), 3); | |
987 | is($ret[0], 'c'); | |
988 | is($ret[1], 'baz'); | |
989 | is($ret[2], 'x'); | |
990 | @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w'); | |
991 | is(scalar(@ret), 3); | |
992 | is($ret[0], 'd'); | |
993 | is($ret[1], 'quux'); | |
994 | is($ret[2], 'w'); | |
995 | ||
8e4ecf23 JL |
996 | close RT73690_2 or die "Could not close: $!"; |
997 | })[0]; | |
998 | ||
ee23553f FC |
999 | open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
1000 | select +(select(UNDEF), $~ = "UNDEFFORMAT")[0]; | |
1001 | format UNDEFFORMAT = | |
1002 | @ | |
1003 | undef *UNDEFFORMAT | |
1004 | . | |
1005 | write UNDEF; | |
1006 | pass "active format cannot be freed"; | |
c782dc1d FC |
1007 | |
1008 | select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0]; | |
1009 | format UNDEFFORMAT2 = | |
1010 | @ | |
1011 | close UNDEF or die "Could not close: $!"; undef *UNDEF | |
1012 | . | |
1013 | write UNDEF; | |
1014 | pass "freeing current handle in format"; | |
1015 | undef $^A; | |
ee23553f | 1016 | |
7c70caa5 FC |
1017 | ok !eval q| |
1018 | format foo { | |
1019 | @<<< | |
1020 | $a | |
1021 | } | |
1022 | ;1 | |
1023 | |, 'format foo { ... } is not allowed'; | |
1024 | ||
1025 | ok !eval q| | |
1026 | format = | |
1027 | @<<< | |
1028 | } | |
1029 | ;1 | |
1030 | |, 'format = ... } is not allowed'; | |
1031 | ||
64a40898 FC |
1032 | open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
1033 | format NEST = | |
1034 | @<<< | |
1035 | { | |
1036 | my $birds = "birds"; | |
1037 | local *NEST = *BIRDS{FORMAT}; | |
1038 | write NEST; | |
1039 | format BIRDS = | |
1040 | @<<<<< | |
1041 | $birds; | |
1042 | . | |
1043 | "nest" | |
1044 | } | |
1045 | . | |
1046 | write NEST; | |
1047 | close NEST or die "Could not close: $!"; | |
1048 | is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats'; | |
1049 | ||
2c658e55 FC |
1050 | # A compilation error should not create a format |
1051 | eval q| | |
1052 | format ERROR = | |
1053 | @ | |
1054 | @_ =~ s/// | |
1055 | . | |
1056 | |; | |
1057 | eval { write ERROR }; | |
1058 | like $@, qr'Undefined format', | |
1059 | 'formats with compilation errors are not created'; | |
1060 | ||
6c7ae946 FC |
1061 | # This syntax error used to cause a crash, double free, or a least |
1062 | # a bad read. | |
1063 | # See the long-winded explanation at: | |
1064 | # https://rt.perl.org/rt3/Ticket/Display.html?id=43425#txn-1144500 | |
1065 | eval q| | |
1066 | format = | |
1067 | @ | |
1068 | use;format | |
1069 | strict | |
1070 | . | |
1071 | |; | |
1072 | pass('no crash with invalid use/format inside format'); | |
1073 | ||
ee23553f | 1074 | |
705fe0e5 FC |
1075 | # Low-precedence operators on argument line |
1076 | format AND = | |
1077 | @ | |
1078 | 0 and die | |
1079 | . | |
1080 | $- = $=; | |
1081 | ok eval { local $~ = "AND"; print "# "; write; 1 }, | |
1082 | "low-prec ops on arg line" or diag $@; | |
1083 | ||
1084 | # Anonymous hashes | |
1085 | open(HASH, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
1086 | format HASH = | |
1087 | @<<< | |
1088 | ${{qw[ Sun 0 Mon 1 Tue 2 Wed 3 Thu 4 Fri 5 Sat 6 ]}}{"Wed"} | |
1089 | . | |
1090 | write HASH; | |
1091 | close HASH or die "Could not close: $!"; | |
1092 | is cat('Op_write.tmp'), "3\n", 'anonymous hashes'; | |
1093 | ||
1094 | # pragmata inside argument line | |
1095 | open(STRICT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
1096 | format STRICT = | |
1097 | @<<< | |
1098 | no strict; $foo | |
1099 | . | |
1100 | $::foo = 'oof::$'; | |
1101 | write STRICT; | |
1102 | close STRICT or die "Could not close: $!"; | |
1103 | is cat('Op_write.tmp'), "oof:\n", 'pragmata on format line'; | |
1104 | ||
7c93c29b FC |
1105 | SKIP: { |
1106 | skip "no weak refs" unless eval { require Scalar::Util }; | |
1107 | sub Potshriggley { | |
1108 | format Potshriggley = | |
1109 | . | |
1110 | } | |
1111 | Scalar::Util::weaken(my $x = *Potshriggley{FORMAT}); | |
1112 | undef *Potshriggley; | |
1113 | is $x, undef, 'formats in subs do not leak'; | |
7c93c29b FC |
1114 | } |
1115 | ||
705fe0e5 | 1116 | |
2027357e NC |
1117 | ############################# |
1118 | ## Section 4 | |
1119 | ## Add new tests *above* here | |
1120 | ############################# | |
1121 | ||
f5b75c1c NC |
1122 | # scary format testing from H.Merijn Brand |
1123 | ||
1124 | # Just a complete test for format, including top-, left- and bottom marging | |
1125 | # and format detection through glob entries | |
1126 | ||
7b903762 | 1127 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || |
f5b75c1c NC |
1128 | ($^O eq 'os2' and not eval '$OS2::can_fork')) { |
1129 | $test = curr_test(); | |
1130 | SKIP: { | |
1131 | skip "'|-' and '-|' not supported", $tests - $test + 1; | |
1132 | } | |
1133 | exit(0); | |
1134 | } | |
1135 | ||
1136 | ||
0bd0581c DM |
1137 | $^ = "STDOUT_TOP"; |
1138 | $= = 7; # Page length | |
1139 | $- = 0; # Lines left | |
9ccde9ea JH |
1140 | my $ps = $^L; $^L = ""; # Catch the page separator |
1141 | my $tm = 1; # Top margin (empty lines before first output) | |
1142 | my $bm = 2; # Bottom marging (empty lines between last text and footer) | |
1143 | my $lm = 4; # Left margin (indent in spaces) | |
1144 | ||
68ba3c2c DM |
1145 | # ----------------------------------------------------------------------- |
1146 | # | |
1147 | # execute the rest of the script in a child process. The parent reads the | |
1148 | # output from the child and compares it with <DATA>. | |
1149 | ||
1150 | my @data = <DATA>; | |
1151 | ||
1152 | select ((select (STDOUT), $| = 1)[0]); # flush STDOUT | |
1153 | ||
1154 | my $opened = open FROM_CHILD, "-|"; | |
1155 | unless (defined $opened) { | |
6108250c NC |
1156 | fail "open gave $!"; |
1157 | exit 0; | |
68ba3c2c DM |
1158 | } |
1159 | ||
1160 | if ($opened) { | |
1161 | # in parent here | |
1162 | ||
6108250c | 1163 | pass 'open'; |
9ccde9ea | 1164 | my $s = " " x $lm; |
68ba3c2c DM |
1165 | while (<FROM_CHILD>) { |
1166 | unless (@data) { | |
6108250c | 1167 | fail 'too much output'; |
68ba3c2c DM |
1168 | exit; |
1169 | } | |
9ccde9ea | 1170 | s/^/$s/; |
68ba3c2c | 1171 | my $exp = shift @data; |
6108250c | 1172 | is $_, $exp; |
9ccde9ea | 1173 | } |
68ba3c2c | 1174 | close FROM_CHILD; |
6108250c | 1175 | is "@data", "", "correct length of output"; |
68ba3c2c DM |
1176 | exit; |
1177 | } | |
1178 | ||
1179 | # in child here | |
6108250c | 1180 | $::NO_ENDING = 1; |
68ba3c2c DM |
1181 | |
1182 | select ((select (STDOUT), $| = 1)[0]); | |
9ccde9ea JH |
1183 | $tm = "\n" x $tm; |
1184 | $= -= $bm + 1; # count one for the trailing "----" | |
1185 | my $lastmin = 0; | |
1186 | ||
1187 | my @E; | |
1188 | ||
1189 | sub wryte | |
1190 | { | |
1191 | $lastmin = $-; | |
1192 | write; | |
1193 | } # wryte; | |
1194 | ||
1195 | sub footer | |
1196 | { | |
1197 | $% == 1 and return ""; | |
1198 | ||
1199 | $lastmin < $= and print "\n" x $lastmin; | |
1200 | print "\n" x $bm, "----\n", $ps; | |
1201 | $lastmin = $-; | |
1202 | ""; | |
1203 | } # footer | |
1204 | ||
1205 | # Yes, this is sick ;-) | |
1206 | format TOP = | |
1207 | @* ~ | |
1208 | @{[footer]} | |
1209 | @* ~ | |
1210 | $tm | |
1211 | . | |
1212 | ||
9ccde9ea JH |
1213 | format ENTRY = |
1214 | @ @<<<<~~ | |
1215 | @{(shift @E)||["",""]} | |
1216 | . | |
1217 | ||
1218 | format EOR = | |
1219 | - ----- | |
1220 | . | |
1221 | ||
1222 | sub has_format ($) | |
1223 | { | |
1224 | my $fmt = shift; | |
1225 | exists $::{$fmt} or return 0; | |
1226 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; | |
1227 | open my $null, "> /dev/null" or die; | |
1228 | my $fh = select $null; | |
1229 | local $~ = $fmt; | |
1230 | eval "write"; | |
1231 | select $fh; | |
1232 | $@?0:1; | |
1233 | } # has_format | |
1234 | ||
d57f9278 | 1235 | $^ = has_format ("TOP") ? "TOP" : "EMPTY"; |
9ccde9ea JH |
1236 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
1237 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], | |
1238 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { | |
1239 | @E = @$e; | |
1240 | local $~ = "ENTRY"; | |
1241 | wryte; | |
1242 | has_format ("EOR") or next; | |
1243 | local $~ = "EOR"; | |
1244 | wryte; | |
1245 | } | |
1246 | if (has_format ("EOF")) { | |
1247 | local $~ = "EOF"; | |
1248 | wryte; | |
1249 | } | |
1250 | ||
1251 | close STDOUT; | |
1252 | ||
ea42cebc | 1253 | # That was test 48. |
9ccde9ea JH |
1254 | |
1255 | __END__ | |
1256 | ||
1257 | 1 Test1 | |
1258 | 2 Test2 | |
1259 | 3 Test3 | |
1260 | ||
1261 | ||
1262 | ---- | |
1263 | \f | |
1264 | 4 Test4 | |
1265 | 5 Test5 | |
1266 | 6 Test6 | |
1267 | ||
1268 | ||
1269 | ---- | |
1270 | \f | |
1271 | 7 Test7 | |
1272 | - ----- | |
1273 | ||
1274 | ||
1275 | ||
1276 | ---- | |
1277 | \f | |
1278 | 1 1tseT | |
1279 | 2 2tseT | |
1280 | 3 3tseT | |
1281 | ||
1282 | ||
1283 | ---- | |
1284 | \f | |
1285 | 4 4tseT | |
1286 | 5 5tseT | |
1287 | - ----- |