Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
9ccde9ea JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
6108250c | 5 | require './test.pl'; |
43ece5b1 | 6 | set_up_inc('../lib'); |
9ccde9ea JH |
7 | } |
8 | ||
470e8f06 KW |
9 | $| = 0; # test.pl now sets it on, which causes problems here. |
10 | ||
90f67b00 | 11 | use strict; # Amazed that this hackery can be made strict ... |
9b4bdfd4 | 12 | use Tie::Scalar; |
90f67b00 | 13 | |
a344b90b DM |
14 | # read in a file |
15 | sub cat { | |
16 | my $file = shift; | |
17 | local $/; | |
18 | open my $fh, $file or die "can't open '$file': $!"; | |
19 | my $data = <$fh>; | |
20 | close $fh; | |
21 | $data; | |
22 | } | |
23 | ||
9b4bdfd4 DM |
24 | # read in a utf-8 file |
25 | # | |
26 | sub cat_utf8 { | |
27 | my $file = shift; | |
28 | local $/; | |
29 | open my $fh, '<', $file or die "can't open '$file': $!"; | |
30 | binmode $fh, ':utf8'; | |
31 | my $data = <$fh> // die "Can't read from '$file': $!"; | |
32 | close $fh or die "error closing '$file': $!"; | |
33 | $data; | |
34 | } | |
35 | ||
36 | # write a format to a utf8 file, then read it back in and compare | |
37 | ||
38 | sub is_format_utf8 { | |
39 | my ($glob, $want, $desc) = @_; | |
40 | local $::Level = $::Level + 1; | |
41 | my $file = 'Op_write.tmp'; | |
42 | open $glob, '>:utf8', $file or die "Can't create '$file': $!"; | |
43 | write $glob; | |
44 | close $glob or die "Could not close '$file': $!"; | |
45 | is(cat_utf8($file), $want, $desc); | |
46 | } | |
47 | ||
48 | sub like_format_utf8 { | |
49 | my ($glob, $want, $desc) = @_; | |
50 | local $::Level = $::Level + 1; | |
51 | my $file = 'Op_write.tmp'; | |
52 | open $glob, '>:utf8', $file or die "Can't create '$file': $!"; | |
53 | write $glob; | |
54 | close $glob or die "Could not close '$file': $!"; | |
55 | like(cat_utf8($file), $want, $desc); | |
56 | } | |
57 | ||
58 | ||
59 | ||
a1b95068 WL |
60 | #-- testing numeric fields in all variants (WL) |
61 | ||
62 | sub swrite { | |
63 | my $format = shift; | |
64 | local $^A = ""; # don't litter, use a local bin | |
65 | formline( $format, @_ ); | |
66 | return $^A; | |
67 | } | |
68 | ||
69 | my @NumTests = ( | |
d1f6232e | 70 | # [ format, value1, expected1, value2, expected2, .... ] |
9acd3e2c DM |
71 | [ '@###', 0, ' 0', 1, ' 1', 9999.6, '####', |
72 | 9999.4999, '9999', -999.6, '####', 1e+100, '####' ], | |
d1f6232e | 73 | |
9acd3e2c DM |
74 | [ '@0##', 0, '0000', 1, '0001', 9999.6, '####', |
75 | -999.4999, '-999', -999.6, '####', 1e+100, '####' ], | |
d1f6232e DM |
76 | |
77 | [ '^###', 0, ' 0', undef, ' ' ], | |
78 | ||
79 | [ '^0##', 0, '0000', undef, ' ' ], | |
80 | ||
9acd3e2c DM |
81 | [ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####', |
82 | 9999.4999, '9999.', -999.6, '#####' ], | |
d1f6232e | 83 | |
9acd3e2c | 84 | [ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######', |
d1f6232e DM |
85 | 999.99499, '999.99', -100, '######' ], |
86 | ||
87 | [ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00', | |
8975a8c2 | 88 | -0.0001, qr/^[\-0]00\.00$/ ], |
d1f6232e DM |
89 | |
90 | ); | |
91 | ||
a1b95068 WL |
92 | |
93 | my $num_tests = 0; | |
94 | for my $tref ( @NumTests ){ | |
d1f6232e | 95 | $num_tests += (@$tref - 1)/2; |
a1b95068 WL |
96 | } |
97 | #--------------------------------------------------------- | |
98 | ||
99 | # number of tests in section 1 | |
b27dce25 | 100 | my $bas_tests = 21; |
a1b95068 WL |
101 | |
102 | # number of tests in section 3 | |
c7321345 | 103 | my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 14; |
a1b95068 | 104 | |
f5b75c1c | 105 | # number of tests in section 4 |
f60e6763 | 106 | my $hmb_tests = 37; |
f5b75c1c NC |
107 | |
108 | my $tests = $bas_tests + $num_tests + $bug_tests + $hmb_tests; | |
6108250c NC |
109 | |
110 | plan $tests; | |
a687059c | 111 | |
a1b95068 WL |
112 | ############ |
113 | ## Section 1 | |
114 | ############ | |
115 | ||
83461ff8 | 116 | our ($fox, $multiline, $foo, $good); |
90f67b00 | 117 | |
a687059c LW |
118 | format OUT = |
119 | the quick brown @<< | |
120 | $fox | |
121 | jumped | |
122 | @* | |
123 | $multiline | |
124 | ^<<<<<<<<< | |
125 | $foo | |
126 | ^<<<<<<<<< | |
127 | $foo | |
128 | ^<<<<<<... | |
129 | $foo | |
130 | now @<<the@>>>> for all@|||||men to come @<<<< | |
a0d0e21e LW |
131 | { |
132 | 'i' . 's', "time\n", $good, 'to' | |
133 | } | |
a687059c LW |
134 | . |
135 | ||
a0d0e21e | 136 | open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
951af6b5 | 137 | END { unlink_all 'Op_write.tmp' } |
a687059c LW |
138 | |
139 | $fox = 'foxiness'; | |
140 | $good = 'good'; | |
141 | $multiline = "forescore\nand\nseven years\n"; | |
142 | $foo = 'when in the course of human events it becomes necessary'; | |
143 | write(OUT); | |
d1e4d418 | 144 | close OUT or die "Could not close: $!"; |
a687059c | 145 | |
90f67b00 | 146 | my $right = |
a687059c LW |
147 | "the quick brown fox |
148 | jumped | |
149 | forescore | |
150 | and | |
151 | seven years | |
152 | when in | |
153 | the course | |
154 | of huma... | |
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 | |
748a9306 LW |
159 | $fox = 'wolfishness'; |
160 | my $fox = 'foxiness'; # Test a lexical variable. | |
161 | ||
a687059c LW |
162 | format OUT2 = |
163 | the quick brown @<< | |
164 | $fox | |
165 | jumped | |
166 | @* | |
167 | $multiline | |
168 | ^<<<<<<<<< ~~ | |
169 | $foo | |
170 | now @<<the@>>>> for all@|||||men to come @<<<< | |
171 | 'i' . 's', "time\n", $good, 'to' | |
172 | . | |
173 | ||
a0d0e21e | 174 | open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; |
a687059c | 175 | |
a687059c LW |
176 | $good = 'good'; |
177 | $multiline = "forescore\nand\nseven years\n"; | |
178 | $foo = 'when in the course of human events it becomes necessary'; | |
179 | write(OUT2); | |
d1e4d418 | 180 | close OUT2 or die "Could not close: $!"; |
a687059c LW |
181 | |
182 | $right = | |
183 | "the quick brown fox | |
184 | jumped | |
185 | forescore | |
186 | and | |
187 | seven years | |
188 | when in | |
189 | the course | |
190 | of human | |
191 | events it | |
192 | becomes | |
193 | necessary | |
194 | now is the time for all good men to come to\n"; | |
195 | ||
951af6b5 | 196 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
a687059c | 197 | |
0f85fab0 LW |
198 | eval <<'EOFORMAT'; |
199 | format OUT2 = | |
200 | the brown quick @<< | |
201 | $fox | |
202 | jumped | |
203 | @* | |
204 | $multiline | |
a0d0e21e | 205 | and |
0f85fab0 LW |
206 | ^<<<<<<<<< ~~ |
207 | $foo | |
208 | now @<<the@>>>> for all@|||||men to come @<<<< | |
209 | 'i' . 's', "time\n", $good, 'to' | |
210 | . | |
211 | EOFORMAT | |
212 | ||
a0d0e21e | 213 | open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
0f85fab0 LW |
214 | |
215 | $fox = 'foxiness'; | |
216 | $good = 'good'; | |
217 | $multiline = "forescore\nand\nseven years\n"; | |
218 | $foo = 'when in the course of human events it becomes necessary'; | |
219 | write(OUT2); | |
d1e4d418 | 220 | close OUT2 or die "Could not close: $!"; |
0f85fab0 LW |
221 | |
222 | $right = | |
223 | "the brown quick fox | |
224 | jumped | |
225 | forescore | |
226 | and | |
227 | seven years | |
a0d0e21e | 228 | and |
0f85fab0 LW |
229 | when in |
230 | the course | |
231 | of human | |
232 | events it | |
233 | becomes | |
234 | necessary | |
235 | now is the time for all good men to come to\n"; | |
236 | ||
951af6b5 | 237 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
0f85fab0 | 238 | |
55497cff | 239 | # formline tests |
240 | ||
90f67b00 | 241 | $right = <<EOT; |
55497cff | 242 | @ a |
243 | @> ab | |
244 | @>> abc | |
245 | @>>> abc | |
246 | @>>>> abc | |
247 | @>>>>> abc | |
248 | @>>>>>> abc | |
249 | @>>>>>>> abc | |
250 | @>>>>>>>> abc | |
251 | @>>>>>>>>> abc | |
252 | @>>>>>>>>>> abc | |
253 | EOT | |
254 | ||
90f67b00 | 255 | my $was1 = my $was2 = ''; |
83461ff8 | 256 | our $format2; |
55497cff | 257 | for (0..10) { |
258 | # lexical picture | |
259 | $^A = ''; | |
260 | my $format1 = '@' . '>' x $_; | |
261 | formline $format1, 'abc'; | |
262 | $was1 .= "$format1 $^A\n"; | |
263 | # global | |
264 | $^A = ''; | |
265 | local $format2 = '@' . '>' x $_; | |
266 | formline $format2, 'abc'; | |
267 | $was2 .= "$format2 $^A\n"; | |
268 | } | |
90f67b00 NC |
269 | is $was1, $right; |
270 | is $was2, $right; | |
55497cff | 271 | |
7056ecde KM |
272 | $^A = ''; |
273 | ||
274 | # more test | |
275 | ||
276 | format OUT3 = | |
277 | ^<<<<<<... | |
278 | $foo | |
279 | . | |
280 | ||
281 | open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
282 | ||
283 | $foo = 'fit '; | |
284 | write(OUT3); | |
d1e4d418 | 285 | close OUT3 or die "Could not close: $!"; |
7056ecde KM |
286 | |
287 | $right = | |
288 | "fit\n"; | |
289 | ||
951af6b5 | 290 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
2027357e | 291 | |
7056ecde | 292 | |
445b3f51 GS |
293 | # test lexicals and globals |
294 | { | |
2027357e | 295 | my $test = curr_test(); |
445b3f51 | 296 | my $this = "ok"; |
2027357e | 297 | our $that = $test; |
445b3f51 GS |
298 | format LEX = |
299 | @<<@| | |
300 | $this,$that | |
301 | . | |
302 | open(LEX, ">&STDOUT") or die; | |
303 | write LEX; | |
2027357e | 304 | $that = ++$test; |
445b3f51 | 305 | write LEX; |
d1e4d418 | 306 | close LEX or die "Could not close: $!"; |
2027357e | 307 | curr_test($test + 1); |
445b3f51 | 308 | } |
c2e66d9e GS |
309 | # LEX_INTERPNORMAL test |
310 | my %e = ( a => 1 ); | |
311 | format OUT4 = | |
312 | @<<<<<< | |
313 | "$e{a}" | |
314 | . | |
315 | open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; | |
316 | write (OUT4); | |
d1e4d418 | 317 | close OUT4 or die "Could not close: $!"; |
951af6b5 | 318 | is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp"; |
784707d5 | 319 | |
b27dce25 FC |
320 | # More LEX_INTERPNORMAL |
321 | format OUT4a= | |
322 | @<<<<<<<<<<<<<<< | |
323 | "${; use | |
324 | strict; \'Nasdaq dropping like flies'}" | |
325 | . | |
326 | open OUT4a, ">Op_write.tmp" or die "Can't create Op_write.tmp"; | |
327 | write (OUT4a); | |
328 | close OUT4a or die "Could not close: $!"; | |
329 | is cat('Op_write.tmp'), "Nasdaq dropping\n", 'skipspace inside "${...}"' | |
330 | and unlink_all "Op_write.tmp"; | |
331 | ||
83461ff8 | 332 | our $test1; |
784707d5 JP |
333 | eval <<'EOFORMAT'; |
334 | format OUT10 = | |
335 | @####.## @0###.## | |
336 | $test1, $test1 | |
337 | . | |
338 | EOFORMAT | |
339 | ||
340 | open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
341 | ||
342 | $test1 = 12.95; | |
343 | write(OUT10); | |
d1e4d418 | 344 | close OUT10 or die "Could not close: $!"; |
784707d5 JP |
345 | |
346 | $right = " 12.95 00012.95\n"; | |
951af6b5 | 347 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
784707d5 JP |
348 | |
349 | eval <<'EOFORMAT'; | |
350 | format OUT11 = | |
351 | @0###.## | |
352 | $test1 | |
353 | @ 0# | |
354 | $test1 | |
355 | @0 # | |
356 | $test1 | |
357 | . | |
358 | EOFORMAT | |
359 | ||
360 | open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
361 | ||
362 | $test1 = 12.95; | |
363 | write(OUT11); | |
d1e4d418 | 364 | close OUT11 or die "Could not close: $!"; |
784707d5 JP |
365 | |
366 | $right = | |
367 | "00012.95 | |
368 | 1 0# | |
369 | 10 #\n"; | |
951af6b5 | 370 | is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; |
9ccde9ea | 371 | |
31869a79 | 372 | { |
2027357e | 373 | my $test = curr_test(); |
71f882da | 374 | my $el; |
a1b95068 | 375 | format OUT12 = |
31869a79 AE |
376 | ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze |
377 | $el | |
378 | . | |
2027357e | 379 | my %hash = ($test => 3); |
a1b95068 WL |
380 | open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
381 | ||
31869a79 | 382 | for $el (keys %hash) { |
a1b95068 | 383 | write(OUT12); |
31869a79 | 384 | } |
a1b95068 | 385 | close OUT12 or die "Could not close: $!"; |
a344b90b | 386 | print cat('Op_write.tmp'); |
2027357e | 387 | curr_test($test + 1); |
31869a79 AE |
388 | } |
389 | ||
ea42cebc | 390 | { |
2027357e | 391 | my $test = curr_test(); |
ea42cebc | 392 | # Bug report and testcase by Alexey Tourbin |
ea42cebc RGS |
393 | my $v; |
394 | tie $v, 'Tie::StdScalar'; | |
2027357e | 395 | $v = $test; |
ea42cebc RGS |
396 | format OUT13 = |
397 | ok ^<<<<<<<<< ~~ | |
398 | $v | |
399 | . | |
400 | open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
401 | write(OUT13); | |
402 | close OUT13 or die "Could not close: $!"; | |
a344b90b | 403 | print cat('Op_write.tmp'); |
2027357e | 404 | curr_test($test + 1); |
ea42cebc RGS |
405 | } |
406 | ||
a1b95068 WL |
407 | { # test 14 |
408 | # Bug #24774 format without trailing \n failed assertion, but this | |
409 | # must fail since we have a trailing ; in the eval'ed string (WL) | |
f5c235e7 DM |
410 | my @v = ('k'); |
411 | eval "format OUT14 = \n@\n\@v"; | |
2027357e | 412 | like $@, qr/Format not terminated/; |
f5c235e7 DM |
413 | } |
414 | ||
a1b95068 WL |
415 | { # test 15 |
416 | # text lost in ^<<< field with \r in value (WL) | |
417 | my $txt = "line 1\rline 2"; | |
418 | format OUT15 = | |
419 | ^<<<<<<<<<<<<<<<<<< | |
420 | $txt | |
421 | ^<<<<<<<<<<<<<<<<<< | |
422 | $txt | |
423 | . | |
424 | open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
425 | write(OUT15); | |
426 | close OUT15 or die "Could not close: $!"; | |
a344b90b | 427 | my $res = cat('Op_write.tmp'); |
2027357e | 428 | is $res, "line 1\nline 2\n"; |
a1b95068 WL |
429 | } |
430 | ||
431 | { # test 16: multiple use of a variable in same line with ^< | |
432 | my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4"; | |
433 | format OUT16 = | |
434 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< | |
435 | $txt, $txt | |
436 | ^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<< | |
437 | $txt, $txt | |
438 | . | |
439 | open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
440 | write(OUT16); | |
441 | close OUT16 or die "Could not close: $!"; | |
a344b90b | 442 | my $res = cat('Op_write.tmp'); |
2027357e | 443 | is $res, <<EOD; |
a1b95068 WL |
444 | this_is_block_1 this_is_block_2 |
445 | this_is_block_3 this_is_block_4 | |
446 | EOD | |
447 | } | |
448 | ||
449 | { # test 17: @* "should be on a line of its own", but it should work | |
450 | # cleanly with literals before and after. (WL) | |
451 | ||
452 | my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n"; | |
453 | format OUT17 = | |
454 | Here we go: @* That's all, folks! | |
455 | $txt | |
456 | . | |
457 | open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
458 | write(OUT17); | |
459 | close OUT17 or die "Could not close: $!"; | |
a344b90b | 460 | my $res = cat('Op_write.tmp'); |
a1b95068 WL |
461 | chomp( $txt ); |
462 | my $exp = <<EOD; | |
463 | Here we go: $txt That's all, folks! | |
464 | EOD | |
2027357e | 465 | is $res, $exp; |
a1b95068 WL |
466 | } |
467 | ||
468 | { # test 18: @# and ~~ would cause runaway format, but we now | |
469 | # catch this while compiling (WL) | |
470 | ||
471 | format OUT18 = | |
472 | @######## ~~ | |
473 | 10 | |
474 | . | |
475 | open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
476 | eval { write(OUT18); }; | |
2027357e | 477 | like $@, qr/Repeated format line will never terminate/; |
a1b95068 WL |
478 | close OUT18 or die "Could not close: $!"; |
479 | } | |
480 | ||
481 | { # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL) | |
482 | my $v = 'gaga'; | |
483 | eval "format OUT19 = \n" . | |
484 | '@<<<' . "\0\n" . | |
485 | '$v' . "\n" . | |
486 | '@<<<' . "\0\n" . | |
487 | '$v' . "\n.\n"; | |
488 | open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
489 | write(OUT19); | |
a344b90b DM |
490 | close OUT19 or die "Could not close: $!"; |
491 | my $res = cat('Op_write.tmp'); | |
2027357e | 492 | is $res, <<EOD; |
a1b95068 WL |
493 | gaga\0 |
494 | gaga\0 | |
495 | EOD | |
496 | } | |
497 | ||
498 | { # test 20: hash accesses; single '}' must not terminate format '}' (WL) | |
499 | my %h = ( xkey => 'xval', ykey => 'yval' ); | |
500 | format OUT20 = | |
501 | @>>>> @<<<< ~~ | |
502 | each %h | |
503 | @>>>> @<<<< | |
504 | $h{xkey}, $h{ykey} | |
505 | @>>>> @<<<< | |
506 | { $h{xkey}, $h{ykey} | |
507 | } | |
508 | } | |
509 | . | |
510 | my $exp = ''; | |
511 | while( my( $k, $v ) = each( %h ) ){ | |
512 | $exp .= sprintf( "%5s %s\n", $k, $v ); | |
513 | } | |
514 | $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); | |
515 | $exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} ); | |
516 | $exp .= "}\n"; | |
517 | open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
518 | write(OUT20); | |
a344b90b DM |
519 | close OUT20 or die "Could not close: $!"; |
520 | my $res = cat('Op_write.tmp'); | |
2027357e | 521 | is $res, $exp; |
a1b95068 WL |
522 | } |
523 | ||
524 | ||
525 | ##################### | |
526 | ## Section 2 | |
527 | ## numeric formatting | |
528 | ##################### | |
529 | ||
2027357e NC |
530 | curr_test($bas_tests + 1); |
531 | ||
a1b95068 WL |
532 | for my $tref ( @NumTests ){ |
533 | my $writefmt = shift( @$tref ); | |
d1f6232e DM |
534 | while (@$tref) { |
535 | my $val = shift @$tref; | |
536 | my $expected = shift @$tref; | |
a1b95068 | 537 | my $writeres = swrite( $writefmt, $val ); |
2027357e NC |
538 | if (ref $expected) { |
539 | like $writeres, $expected, $writefmt; | |
540 | } else { | |
541 | is $writeres, $expected, $writefmt; | |
542 | } | |
a1b95068 WL |
543 | } |
544 | } | |
545 | ||
546 | ||
547 | ##################################### | |
548 | ## Section 3 | |
f5b75c1c | 549 | ## Easiest to add new tests just here |
2027357e | 550 | ##################################### |
9ccde9ea | 551 | |
30a1e583 DM |
552 | # DAPM. Exercise a couple of error codepaths |
553 | ||
554 | { | |
555 | local $~ = ''; | |
556 | eval { write }; | |
2d1ebc9b | 557 | like $@, qr/Undefined format ""/, 'format with 0-length name'; |
30a1e583 | 558 | |
44b7e78a FC |
559 | $~ = "\0foo"; |
560 | eval { write }; | |
561 | like $@, qr/Undefined format "\0foo"/, | |
562 | 'no such format beginning with null'; | |
563 | ||
30a1e583 DM |
564 | $~ = "NOSUCHFORMAT"; |
565 | eval { write }; | |
44b7e78a | 566 | like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format'; |
30a1e583 DM |
567 | } |
568 | ||
44b7e78a FC |
569 | select +(select(OUT21), do { |
570 | open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
571 | ||
572 | format OUT21 = | |
573 | @<< | |
574 | $_ | |
575 | . | |
576 | ||
577 | local $^ = ''; | |
578 | local $= = 1; | |
579 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
580 | like $@, qr/Undefined top format ""/, 'top format with 0-length name'; | |
581 | ||
582 | $^ = "\0foo"; | |
583 | # For some reason, we have to do this twice to get the error again. | |
584 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
585 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
586 | like $@, qr/Undefined top format "\0foo"/, | |
587 | 'no such top format beginning with null'; | |
588 | ||
589 | $^ = "NOSUCHFORMAT"; | |
590 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
591 | $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; | |
592 | like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format'; | |
593 | ||
594 | # reset things; | |
595 | eval { write(OUT21) }; | |
596 | undef $^A; | |
597 | ||
598 | close OUT21 or die "Could not close: $!"; | |
599 | })[0]; | |
600 | ||
9b4bdfd4 DM |
601 | |
602 | ||
603 | # [perl #119847], [perl #119849], [perl #119851] | |
604 | # Non-real vars like tied, overloaded and refs could, when stringified, | |
605 | # fail to be processed properly, causing infinite loops on ~~, utf8 | |
606 | # warnings etc, ad nauseum. | |
607 | ||
608 | ||
609 | my $u22a = "N" x 8; | |
610 | ||
611 | format OUT22a = | |
612 | '^<<<<<<<<'~~ | |
613 | $u22a | |
614 | . | |
615 | ||
616 | is_format_utf8(\*OUT22a, | |
617 | "'NNNNNNNN '\n"); | |
618 | ||
619 | ||
620 | my $u22b = "N" x 8; | |
621 | utf8::upgrade($u22b); | |
622 | ||
623 | format OUT22b = | |
624 | '^<<<<<<<<'~~ | |
625 | $u22b | |
626 | . | |
627 | ||
628 | is_format_utf8(\*OUT22b, | |
629 | "'NNNNNNNN '\n"); | |
630 | ||
631 | my $u22c = "\x{FF}" x 8; | |
632 | ||
633 | format OUT22c = | |
634 | '^<<<<<<<<'~~ | |
635 | $u22c | |
636 | . | |
637 | ||
638 | is_format_utf8(\*OUT22c, | |
639 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
640 | ||
641 | my $u22d = "\x{FF}" x 8; | |
642 | utf8::upgrade($u22d); | |
643 | ||
644 | format OUT22d = | |
645 | '^<<<<<<<<'~~ | |
646 | $u22d | |
647 | . | |
648 | ||
649 | is_format_utf8(\*OUT22d, | |
650 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
651 | ||
652 | my $u22e = "\x{100}" x 8; | |
653 | ||
654 | format OUT22e = | |
655 | '^<<<<<<<<'~~ | |
656 | $u22e | |
657 | . | |
658 | ||
659 | is_format_utf8(\*OUT22e, | |
660 | "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n"); | |
661 | ||
662 | ||
663 | my $u22f = "N" x 8; | |
664 | ||
665 | format OUT22f = | |
666 | '^<'~~ | |
667 | $u22f | |
668 | . | |
669 | ||
670 | is_format_utf8(\*OUT22f, | |
671 | "'NN'\n"x4); | |
672 | ||
673 | ||
674 | my $u22g = "N" x 8; | |
675 | utf8::upgrade($u22g); | |
676 | ||
677 | format OUT22g = | |
678 | '^<'~~ | |
679 | $u22g | |
680 | . | |
681 | ||
682 | is_format_utf8(\*OUT22g, | |
683 | "'NN'\n"x4); | |
684 | ||
685 | my $u22h = "\x{FF}" x 8; | |
686 | ||
687 | format OUT22h = | |
688 | '^<'~~ | |
689 | $u22h | |
690 | . | |
691 | ||
692 | is_format_utf8(\*OUT22h, | |
693 | "'\x{FF}\x{FF}'\n"x4); | |
694 | ||
695 | my $u22i = "\x{FF}" x 8; | |
696 | utf8::upgrade($u22i); | |
697 | ||
698 | format OUT22i = | |
699 | '^<'~~ | |
700 | $u22i | |
701 | . | |
702 | ||
703 | is_format_utf8(\*OUT22i, | |
704 | "'\x{FF}\x{FF}'\n"x4); | |
705 | ||
706 | my $u22j = "\x{100}" x 8; | |
707 | ||
708 | format OUT22j = | |
709 | '^<'~~ | |
710 | $u22j | |
711 | . | |
712 | ||
713 | is_format_utf8(\*OUT22j, | |
714 | "'\x{100}\x{100}'\n"x4); | |
715 | ||
716 | ||
717 | tie my $u23a, 'Tie::StdScalar'; | |
718 | $u23a = "N" x 8; | |
719 | ||
720 | format OUT23a = | |
721 | '^<<<<<<<<'~~ | |
722 | $u23a | |
723 | . | |
724 | ||
725 | is_format_utf8(\*OUT23a, | |
726 | "'NNNNNNNN '\n"); | |
727 | ||
728 | ||
729 | tie my $u23b, 'Tie::StdScalar'; | |
730 | $u23b = "N" x 8; | |
731 | utf8::upgrade($u23b); | |
732 | ||
733 | format OUT23b = | |
734 | '^<<<<<<<<'~~ | |
735 | $u23b | |
736 | . | |
737 | ||
738 | is_format_utf8(\*OUT23b, | |
739 | "'NNNNNNNN '\n"); | |
740 | ||
741 | tie my $u23c, 'Tie::StdScalar'; | |
742 | $u23c = "\x{FF}" x 8; | |
743 | ||
744 | format OUT23c = | |
745 | '^<<<<<<<<'~~ | |
746 | $u23c | |
747 | . | |
748 | ||
749 | is_format_utf8(\*OUT23c, | |
750 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
751 | ||
752 | tie my $u23d, 'Tie::StdScalar'; | |
753 | my $temp = "\x{FF}" x 8; | |
754 | utf8::upgrade($temp); | |
755 | $u23d = $temp; | |
756 | ||
757 | format OUT23d = | |
758 | '^<<<<<<<<'~~ | |
759 | $u23d | |
760 | . | |
761 | ||
762 | is_format_utf8(\*OUT23d, | |
763 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
764 | ||
765 | tie my $u23e, 'Tie::StdScalar'; | |
766 | $u23e = "\x{100}" x 8; | |
767 | ||
768 | format OUT23e = | |
769 | '^<<<<<<<<'~~ | |
770 | $u23e | |
771 | . | |
772 | ||
773 | is_format_utf8(\*OUT23e, | |
774 | "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n"); | |
775 | ||
776 | tie my $u23f, 'Tie::StdScalar'; | |
777 | $u23f = "N" x 8; | |
778 | ||
779 | format OUT23f = | |
780 | '^<'~~ | |
781 | $u23f | |
782 | . | |
783 | ||
784 | is_format_utf8(\*OUT23f, | |
785 | "'NN'\n"x4); | |
786 | ||
787 | ||
788 | tie my $u23g, 'Tie::StdScalar'; | |
789 | my $temp = "N" x 8; | |
790 | utf8::upgrade($temp); | |
791 | $u23g = $temp; | |
792 | ||
793 | format OUT23g = | |
794 | '^<'~~ | |
795 | $u23g | |
796 | . | |
797 | ||
798 | is_format_utf8(\*OUT23g, | |
799 | "'NN'\n"x4); | |
800 | ||
801 | tie my $u23h, 'Tie::StdScalar'; | |
802 | $u23h = "\x{FF}" x 8; | |
803 | ||
804 | format OUT23h = | |
805 | '^<'~~ | |
806 | $u23h | |
807 | . | |
808 | ||
809 | is_format_utf8(\*OUT23h, | |
810 | "'\x{FF}\x{FF}'\n"x4); | |
811 | ||
812 | $temp = "\x{FF}" x 8; | |
813 | utf8::upgrade($temp); | |
814 | tie my $u23i, 'Tie::StdScalar'; | |
815 | $u23i = $temp; | |
816 | ||
817 | format OUT23i = | |
818 | '^<'~~ | |
819 | $u23i | |
820 | . | |
821 | ||
822 | is_format_utf8(\*OUT23i, | |
823 | "'\x{FF}\x{FF}'\n"x4); | |
824 | ||
825 | tie my $u23j, 'Tie::StdScalar'; | |
826 | $u23j = "\x{100}" x 8; | |
827 | ||
828 | format OUT23j = | |
829 | '^<'~~ | |
830 | $u23j | |
831 | . | |
832 | ||
833 | is_format_utf8(\*OUT23j, | |
834 | "'\x{100}\x{100}'\n"x4); | |
835 | ||
836 | { | |
837 | package UTF8Toggle; | |
838 | ||
839 | sub TIESCALAR { | |
840 | my $class = shift; | |
841 | my $value = shift; | |
842 | my $state = shift||0; | |
843 | return bless [$value, $state], $class; | |
844 | } | |
845 | ||
846 | sub FETCH { | |
847 | my $self = shift; | |
848 | $self->[1] = ! $self->[1]; | |
849 | if ($self->[1]) { | |
850 | utf8::downgrade($self->[0]); | |
851 | } else { | |
852 | utf8::upgrade($self->[0]); | |
853 | } | |
854 | $self->[0]; | |
855 | } | |
856 | ||
857 | sub STORE { | |
858 | my $self = shift; | |
859 | $self->[0] = shift; | |
860 | } | |
861 | } | |
862 | ||
863 | tie my $u24a, 'UTF8Toggle'; | |
864 | $u24a = "N" x 8; | |
865 | ||
866 | format OUT24a = | |
867 | '^<<<<<<<<'~~ | |
868 | $u24a | |
869 | . | |
870 | ||
871 | is_format_utf8(\*OUT24a, | |
872 | "'NNNNNNNN '\n"); | |
873 | ||
874 | ||
875 | tie my $u24b, 'UTF8Toggle'; | |
876 | $u24b = "N" x 8; | |
877 | utf8::upgrade($u24b); | |
878 | ||
879 | format OUT24b = | |
880 | '^<<<<<<<<'~~ | |
881 | $u24b | |
882 | . | |
883 | ||
884 | is_format_utf8(\*OUT24b, | |
885 | "'NNNNNNNN '\n"); | |
886 | ||
887 | tie my $u24c, 'UTF8Toggle'; | |
888 | $u24c = "\x{FF}" x 8; | |
889 | ||
890 | format OUT24c = | |
891 | '^<<<<<<<<'~~ | |
892 | $u24c | |
893 | . | |
894 | ||
895 | is_format_utf8(\*OUT24c, | |
896 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
897 | ||
898 | tie my $u24d, 'UTF8Toggle', 1; | |
899 | $u24d = "\x{FF}" x 8; | |
900 | ||
901 | format OUT24d = | |
902 | '^<<<<<<<<'~~ | |
903 | $u24d | |
904 | . | |
905 | ||
906 | is_format_utf8(\*OUT24d, | |
907 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
908 | ||
909 | ||
910 | ||
911 | tie my $u24f, 'UTF8Toggle'; | |
912 | $u24f = "N" x 8; | |
913 | ||
914 | format OUT24f = | |
915 | '^<'~~ | |
916 | $u24f | |
917 | . | |
918 | ||
919 | is_format_utf8(\*OUT24f, | |
920 | "'NN'\n"x4); | |
921 | ||
922 | ||
923 | tie my $u24g, 'UTF8Toggle'; | |
924 | my $temp = "N" x 8; | |
925 | utf8::upgrade($temp); | |
926 | $u24g = $temp; | |
927 | ||
928 | format OUT24g = | |
929 | '^<'~~ | |
930 | $u24g | |
931 | . | |
932 | ||
933 | is_format_utf8(\*OUT24g, | |
934 | "'NN'\n"x4); | |
935 | ||
936 | tie my $u24h, 'UTF8Toggle'; | |
937 | $u24h = "\x{FF}" x 8; | |
938 | ||
939 | format OUT24h = | |
940 | '^<'~~ | |
941 | $u24h | |
942 | . | |
943 | ||
944 | is_format_utf8(\*OUT24h, | |
945 | "'\x{FF}\x{FF}'\n"x4); | |
946 | ||
947 | tie my $u24i, 'UTF8Toggle', 1; | |
948 | $u24i = "\x{FF}" x 8; | |
949 | ||
950 | format OUT24i = | |
951 | '^<'~~ | |
952 | $u24i | |
953 | . | |
954 | ||
955 | is_format_utf8(\*OUT24i, | |
956 | "'\x{FF}\x{FF}'\n"x4); | |
957 | ||
958 | { | |
959 | package OS; | |
960 | use overload '""' => sub { ${$_[0]}; }; | |
961 | ||
962 | sub new { | |
963 | my ($class, $value) = @_; | |
964 | bless \$value, $class; | |
965 | } | |
966 | } | |
967 | ||
968 | my $u25a = OS->new("N" x 8); | |
969 | ||
970 | format OUT25a = | |
971 | '^<<<<<<<<'~~ | |
972 | $u25a | |
973 | . | |
974 | ||
975 | is_format_utf8(\*OUT25a, | |
976 | "'NNNNNNNN '\n"); | |
977 | ||
978 | ||
979 | my $temp = "N" x 8; | |
980 | utf8::upgrade($temp); | |
981 | my $u25b = OS->new($temp); | |
982 | ||
983 | format OUT25b = | |
984 | '^<<<<<<<<'~~ | |
985 | $u25b | |
986 | . | |
987 | ||
988 | is_format_utf8(\*OUT25b, | |
989 | "'NNNNNNNN '\n"); | |
990 | ||
991 | my $u25c = OS->new("\x{FF}" x 8); | |
992 | ||
993 | format OUT25c = | |
994 | '^<<<<<<<<'~~ | |
995 | $u25c | |
996 | . | |
997 | ||
998 | is_format_utf8(\*OUT25c, | |
999 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
1000 | ||
1001 | $temp = "\x{FF}" x 8; | |
1002 | utf8::upgrade($temp); | |
1003 | my $u25d = OS->new($temp); | |
1004 | ||
1005 | format OUT25d = | |
1006 | '^<<<<<<<<'~~ | |
1007 | $u25d | |
1008 | . | |
1009 | ||
1010 | is_format_utf8(\*OUT25d, | |
1011 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
1012 | ||
1013 | my $u25e = OS->new("\x{100}" x 8); | |
1014 | ||
1015 | format OUT25e = | |
1016 | '^<<<<<<<<'~~ | |
1017 | $u25e | |
1018 | . | |
1019 | ||
1020 | is_format_utf8(\*OUT25e, | |
1021 | "'\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100}\x{100} '\n"); | |
1022 | ||
1023 | ||
1024 | my $u25f = OS->new("N" x 8); | |
1025 | ||
1026 | format OUT25f = | |
1027 | '^<'~~ | |
1028 | $u25f | |
1029 | . | |
1030 | ||
1031 | is_format_utf8(\*OUT25f, | |
1032 | "'NN'\n"x4); | |
1033 | ||
1034 | ||
1035 | $temp = "N" x 8; | |
1036 | utf8::upgrade($temp); | |
1037 | my $u25g = OS->new($temp); | |
1038 | ||
1039 | format OUT25g = | |
1040 | '^<'~~ | |
1041 | $u25g | |
1042 | . | |
1043 | ||
1044 | is_format_utf8(\*OUT25g, | |
1045 | "'NN'\n"x4); | |
1046 | ||
1047 | my $u25h = OS->new("\x{FF}" x 8); | |
1048 | ||
1049 | format OUT25h = | |
1050 | '^<'~~ | |
1051 | $u25h | |
1052 | . | |
1053 | ||
1054 | is_format_utf8(\*OUT25h, | |
1055 | "'\x{FF}\x{FF}'\n"x4); | |
1056 | ||
1057 | $temp = "\x{FF}" x 8; | |
1058 | utf8::upgrade($temp); | |
1059 | my $u25i = OS->new($temp); | |
1060 | ||
1061 | format OUT25i = | |
1062 | '^<'~~ | |
1063 | $u25i | |
1064 | . | |
1065 | ||
1066 | is_format_utf8(\*OUT25i, | |
1067 | "'\x{FF}\x{FF}'\n"x4); | |
1068 | ||
1069 | my $u25j = OS->new("\x{100}" x 8); | |
1070 | ||
1071 | format OUT25j = | |
1072 | '^<'~~ | |
1073 | $u25j | |
1074 | . | |
1075 | ||
1076 | is_format_utf8(\*OUT25j, | |
1077 | "'\x{100}\x{100}'\n"x4); | |
1078 | ||
1079 | { | |
1080 | package OS::UTF8Toggle; | |
1081 | use overload '""' => sub { | |
1082 | my $self = shift; | |
1083 | $self->[1] = ! $self->[1]; | |
1084 | if ($self->[1]) { | |
1085 | utf8::downgrade($self->[0]); | |
1086 | } else { | |
1087 | utf8::upgrade($self->[0]); | |
1088 | } | |
1089 | $self->[0]; | |
1090 | }; | |
1091 | ||
1092 | sub new { | |
1093 | my ($class, $value, $state) = @_; | |
1094 | bless [$value, $state], $class; | |
1095 | } | |
1096 | } | |
1097 | ||
1098 | ||
1099 | my $u26a = OS::UTF8Toggle->new("N" x 8); | |
1100 | ||
1101 | format OUT26a = | |
1102 | '^<<<<<<<<'~~ | |
1103 | $u26a | |
1104 | . | |
1105 | ||
1106 | is_format_utf8(\*OUT26a, | |
1107 | "'NNNNNNNN '\n"); | |
1108 | ||
1109 | ||
1110 | my $u26b = OS::UTF8Toggle->new("N" x 8, 1); | |
1111 | ||
1112 | format OUT26b = | |
1113 | '^<<<<<<<<'~~ | |
1114 | $u26b | |
1115 | . | |
1116 | ||
1117 | is_format_utf8(\*OUT26b, | |
1118 | "'NNNNNNNN '\n"); | |
1119 | ||
1120 | my $u26c = OS::UTF8Toggle->new("\x{FF}" x 8); | |
1121 | ||
1122 | format OUT26c = | |
1123 | '^<<<<<<<<'~~ | |
1124 | $u26c | |
1125 | . | |
1126 | ||
1127 | is_format_utf8(\*OUT26c, | |
1128 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
1129 | ||
1130 | my $u26d = OS::UTF8Toggle->new("\x{FF}" x 8, 1); | |
1131 | ||
1132 | format OUT26d = | |
1133 | '^<<<<<<<<'~~ | |
1134 | $u26d | |
1135 | . | |
1136 | ||
1137 | is_format_utf8(\*OUT26d, | |
1138 | "'\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF}\x{FF} '\n"); | |
1139 | ||
1140 | ||
1141 | my $u26f = OS::UTF8Toggle->new("N" x 8); | |
1142 | ||
1143 | format OUT26f = | |
1144 | '^<'~~ | |
1145 | $u26f | |
1146 | . | |
1147 | ||
1148 | is_format_utf8(\*OUT26f, | |
1149 | "'NN'\n"x4); | |
1150 | ||
1151 | ||
1152 | my $u26g = OS::UTF8Toggle->new("N" x 8, 1); | |
1153 | ||
1154 | format OUT26g = | |
1155 | '^<'~~ | |
1156 | $u26g | |
1157 | . | |
1158 | ||
1159 | is_format_utf8(\*OUT26g, | |
1160 | "'NN'\n"x4); | |
1161 | ||
1162 | my $u26h = OS::UTF8Toggle->new("\x{FF}" x 8); | |
1163 | ||
1164 | format OUT26h = | |
1165 | '^<'~~ | |
1166 | $u26h | |
1167 | . | |
1168 | ||
1169 | is_format_utf8(\*OUT26h, | |
1170 | "'\x{FF}\x{FF}'\n"x4); | |
1171 | ||
1172 | my $u26i = OS::UTF8Toggle->new("\x{FF}" x 8, 1); | |
1173 | ||
1174 | format OUT26i = | |
1175 | '^<'~~ | |
1176 | $u26i | |
1177 | . | |
1178 | ||
1179 | is_format_utf8(\*OUT26i, | |
1180 | "'\x{FF}\x{FF}'\n"x4); | |
1181 | ||
1182 | ||
1183 | ||
1184 | { | |
1185 | my $zero = $$ - $$; | |
1186 | ||
1187 | package Number; | |
1188 | ||
1189 | sub TIESCALAR { | |
1190 | my $class = shift; | |
1191 | my $value = shift; | |
1192 | return bless \$value, $class; | |
1193 | } | |
1194 | ||
1195 | # The return value should always be SvNOK() only: | |
1196 | sub FETCH { | |
1197 | my $self = shift; | |
1198 | # avoid "" getting converted to "0" and thus | |
1199 | # causing an infinite loop | |
1200 | return "" unless length ($$self); | |
1201 | return $$self - 0.5 + $zero + 0.5; | |
1202 | } | |
1203 | ||
1204 | sub STORE { | |
1205 | my $self = shift; | |
1206 | $$self = shift; | |
1207 | } | |
1208 | ||
1209 | package ONumber; | |
1210 | ||
1211 | use overload '""' => sub { | |
1212 | my $self = shift; | |
1213 | return $$self - 0.5 + $zero + 0.5; | |
1214 | }; | |
1215 | ||
1216 | sub new { | |
1217 | my $class = shift; | |
1218 | my $value = shift; | |
1219 | return bless \$value, $class; | |
1220 | } | |
1221 | } | |
1222 | ||
1223 | my $v27a = 1/256; | |
1224 | ||
1225 | format OUT27a = | |
1226 | '^<<<<<<<<<'~~ | |
1227 | $v27a | |
1228 | . | |
1229 | ||
1230 | is_format_utf8(\*OUT27a, | |
1231 | "'0.00390625'\n"); | |
1232 | ||
1233 | my $v27b = 1/256; | |
1234 | ||
1235 | format OUT27b = | |
1236 | '^<'~~ | |
1237 | $v27b | |
1238 | . | |
1239 | ||
1240 | is_format_utf8(\*OUT27b, | |
1241 | "'0.'\n'00'\n'39'\n'06'\n'25'\n"); | |
1242 | ||
1243 | tie my $v27c, 'Number', 1/256; | |
1244 | ||
1245 | format OUT27c = | |
1246 | '^<<<<<<<<<'~~ | |
1247 | $v27c | |
1248 | . | |
1249 | ||
1250 | is_format_utf8(\*OUT27c, | |
1251 | "'0.00390625'\n"); | |
1252 | ||
1253 | my $v27d = 1/256; | |
1254 | ||
1255 | format OUT27d = | |
1256 | '^<'~~ | |
1257 | $v27d | |
1258 | . | |
1259 | ||
1260 | is_format_utf8(\*OUT27d, | |
1261 | "'0.'\n'00'\n'39'\n'06'\n'25'\n"); | |
1262 | ||
1263 | my $v27e = ONumber->new(1/256); | |
1264 | ||
1265 | format OUT27e = | |
1266 | '^<<<<<<<<<'~~ | |
1267 | $v27e | |
1268 | . | |
1269 | ||
1270 | is_format_utf8(\*OUT27e, | |
1271 | "'0.00390625'\n"); | |
1272 | ||
1273 | my $v27f = ONumber->new(1/256); | |
1274 | ||
1275 | format OUT27f = | |
1276 | '^<'~~ | |
1277 | $v27f | |
1278 | . | |
1279 | ||
1280 | is_format_utf8(\*OUT27f, | |
1281 | "'0.'\n'00'\n'39'\n'06'\n'25'\n"); | |
1282 | ||
1283 | { | |
1284 | package Ref; | |
1285 | use overload '""' => sub { | |
1286 | return ${$_[0]}; | |
1287 | }; | |
1288 | ||
1289 | sub new { | |
1290 | my $class = shift; | |
1291 | my $value = shift; | |
1292 | return bless \$value, $class; | |
1293 | } | |
1294 | } | |
1295 | ||
1296 | my $v28a = {}; | |
1297 | ||
1298 | format OUT28a = | |
1299 | '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~ | |
1300 | $v28a | |
1301 | . | |
1302 | ||
1303 | ||
1304 | # 'HASH(0x1716b60) ' | |
1305 | my $qr_hash = qr/^'HASH\(0x[0-9a-f]+\)\s+'\n$/; | |
1306 | ||
1307 | # 'HASH' | |
1308 | # '(0x1' | |
1309 | # '716b' | |
1310 | # 'c0) ' | |
1311 | my $qr_hash_m = qr/^'HASH'\n('[0-9a-fx() ]{4}'\n)+$/; | |
1312 | ||
1313 | like_format_utf8(\*OUT28a, $qr_hash); | |
1314 | ||
1315 | my $v28b = {}; | |
1316 | ||
1317 | format OUT28b = | |
1318 | '^<<<'~~ | |
1319 | $v28b | |
1320 | . | |
1321 | ||
1322 | like_format_utf8(\*OUT28b, $qr_hash_m); | |
1323 | ||
1324 | ||
1325 | tie my $v28c, 'Tie::StdScalar'; | |
1326 | $v28c = {}; | |
1327 | ||
1328 | format OUT28c = | |
1329 | '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~ | |
1330 | $v28c | |
1331 | . | |
1332 | ||
1333 | like_format_utf8(\*OUT28c, $qr_hash); | |
1334 | ||
1335 | tie my $v28d, 'Tie::StdScalar'; | |
1336 | $v28d = {}; | |
1337 | ||
1338 | format OUT28d = | |
1339 | '^<<<'~~ | |
1340 | $v28d | |
1341 | . | |
1342 | ||
1343 | like_format_utf8(\*OUT28d, $qr_hash_m); | |
1344 | ||
1345 | my $v28e = Ref->new({}); | |
1346 | ||
1347 | format OUT28e = | |
1348 | '^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<'~~ | |
1349 | $v28e | |
1350 | . | |
1351 | ||
1352 | like_format_utf8(\*OUT28e, $qr_hash); | |
1353 | ||
1354 | my $v28f = Ref->new({}); | |
1355 | ||
1356 | format OUT28f = | |
1357 | '^<<<'~~ | |
1358 | $v28f | |
1359 | . | |
1360 | ||
1361 | like_format_utf8(\*OUT28f, $qr_hash_m); | |
1362 | ||
1363 | ||
1364 | ||
f3f2f1a3 | 1365 | { |
e8e72d41 NC |
1366 | package Count; |
1367 | ||
1368 | sub TIESCALAR { | |
1369 | my $class = shift; | |
1370 | bless [shift, 0, 0], $class; | |
1371 | } | |
1372 | ||
1373 | sub FETCH { | |
1374 | my $self = shift; | |
1375 | ++$self->[1]; | |
1376 | $self->[0]; | |
1377 | } | |
1378 | ||
1379 | sub STORE { | |
1380 | my $self = shift; | |
1381 | ++$self->[2]; | |
1382 | $self->[0] = shift; | |
1383 | } | |
1384 | } | |
1385 | ||
1386 | { | |
1387 | my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a} | |
f3f2f1a3 NC |
1388 | my ($pound, $pm) = ("\xA3", "\xB1"); |
1389 | ||
1390 | foreach my $first ('N', $pound, $pound_utf8) { | |
1391 | foreach my $base ('N', $pm, $pm_utf8) { | |
003d2c64 NC |
1392 | foreach my $second ($base, "$base\n", "$base\nMoo!", "$base\nMoo!\n", |
1393 | "$base\nMoo!\n",) { | |
1394 | foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) { | |
1395 | my ($format, $re) = @$_; | |
b57b1734 | 1396 | $format = "1^*2 3${format}4"; |
e8e72d41 | 1397 | foreach my $class ('', 'Count') { |
b57b1734 | 1398 | my $name = qq{swrite("$format", "$first", "$second") class="$class"}; |
e8e72d41 | 1399 | $name =~ s/\n/\\n/g; |
b57b1734 DM |
1400 | $name =~ s{(.)}{ |
1401 | ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1 | |
1402 | }ge; | |
e8e72d41 NC |
1403 | |
1404 | $first =~ /(.+)/ or die $first; | |
1405 | my $expect = "1${1}2"; | |
1406 | $second =~ $re or die $second; | |
1407 | $expect .= " 3${1}4"; | |
1408 | ||
1409 | if ($class) { | |
1410 | my $copy1 = $first; | |
1411 | my $copy2; | |
1412 | tie $copy2, $class, $second; | |
b57b1734 | 1413 | is swrite("$format", $copy1, $copy2), $expect, $name; |
e8e72d41 NC |
1414 | my $obj = tied $copy2; |
1415 | is $obj->[1], 1, 'value read exactly once'; | |
1416 | } else { | |
1417 | my ($copy1, $copy2) = ($first, $second); | |
b57b1734 | 1418 | is swrite("$format", $copy1, $copy2), $expect, $name; |
e8e72d41 NC |
1419 | } |
1420 | } | |
003d2c64 | 1421 | } |
f3f2f1a3 NC |
1422 | } |
1423 | } | |
1424 | } | |
1425 | } | |
9ccde9ea | 1426 | |
35c6393c NC |
1427 | { |
1428 | # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because | |
1429 | # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will | |
1430 | # be doing something similarly out of bounds on everything from 5.000 | |
1431 | my $ref = []; | |
9b4bdfd4 DM |
1432 | my $exp = ">$ref<"; |
1433 | is swrite('>^*<', $ref), $exp; | |
1434 | $ref = []; | |
1435 | my $exp = ">$ref<"; | |
1436 | is swrite('>@*<', $ref), $exp; | |
35c6393c NC |
1437 | } |
1438 | ||
d57f9278 MB |
1439 | format EMPTY = |
1440 | . | |
1441 | ||
f5b75c1c | 1442 | my $test = curr_test(); |
6108250c | 1443 | |
d57f9278 MB |
1444 | format Comment = |
1445 | ok @<<<<< | |
1446 | $test | |
1447 | . | |
1448 | ||
d57f9278 | 1449 | |
64eff8b7 | 1450 | # RT #8698 format bug with undefined _TOP |
0bd0581c DM |
1451 | |
1452 | open STDOUT_DUP, ">&STDOUT"; | |
1453 | my $oldfh = select STDOUT_DUP; | |
1454 | $= = 10; | |
6108250c NC |
1455 | { |
1456 | local $~ = "Comment"; | |
1457 | write; | |
1458 | curr_test($test + 1); | |
64eff8b7 | 1459 | is $-, 9; |
6108250c | 1460 | is $^, "STDOUT_DUP_TOP"; |
0bd0581c DM |
1461 | } |
1462 | select $oldfh; | |
68ba3c2c | 1463 | close STDOUT_DUP; |
d57f9278 | 1464 | |
ef595a33 MB |
1465 | *CmT = *{$::{Comment}}{FORMAT}; |
1466 | ok defined *{$::{CmT}}{FORMAT}, "glob assign"; | |
1467 | ||
3808a683 DM |
1468 | |
1469 | # RT #91032: Check that "non-real" strings like tie and overload work, | |
1470 | # especially that they re-compile the pattern on each FETCH, and that | |
1471 | # they don't overrun the buffer | |
1472 | ||
1473 | ||
1474 | { | |
1475 | package RT91032; | |
1476 | ||
1477 | sub TIESCALAR { bless [] } | |
1478 | my $i = 0; | |
1479 | sub FETCH { $i++; "A$i @> Z\n" } | |
1480 | ||
1481 | use overload '""' => \&FETCH; | |
1482 | ||
1483 | tie my $f, 'RT91032'; | |
1484 | ||
1485 | formline $f, "a"; | |
1486 | formline $f, "bc"; | |
1487 | ::is $^A, "A1 a Z\nA2 bc Z\n", "RT 91032: tied"; | |
1488 | $^A = ''; | |
1489 | ||
1490 | my $g = bless []; # has overloaded stringify | |
1491 | formline $g, "de"; | |
1492 | formline $g, "f"; | |
1493 | ::is $^A, "A3 de Z\nA4 f Z\n", "RT 91032: overloaded"; | |
1494 | $^A = ''; | |
1495 | ||
1496 | my $h = []; | |
1497 | formline $h, "junk1"; | |
1498 | formline $h, "junk2"; | |
1499 | ::is ref($h), 'ARRAY', "RT 91032: array ref still a ref"; | |
1500 | ::like "$h", qr/^ARRAY\(0x[0-9a-f]+\)$/, "RT 91032: array stringifies ok"; | |
1501 | ::is $^A, "$h$h","RT 91032: stringified array"; | |
1502 | $^A = ''; | |
1503 | ||
1504 | # used to overwrite the ~~ in the *original SV with spaces. Naughty! | |
1505 | ||
1506 | my $orig = my $format = "^<<<<< ~~\n"; | |
1507 | my $abc = "abc"; | |
1508 | formline $format, $abc; | |
1509 | $^A =''; | |
1510 | ::is $format, $orig, "RT91032: don't overwrite orig format string"; | |
1511 | ||
b57b1734 DM |
1512 | # check that ~ and ~~ are displayed correctly as whitespace, |
1513 | # under the influence of various different types of border | |
1514 | ||
1515 | for my $n (1,2) { | |
1516 | for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') { | |
1517 | for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') { | |
1518 | my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n"; | |
1519 | my $sfmt = ($fmt =~ s/~/ /gr); | |
1520 | my ($a, $bc, $stop); | |
1521 | ($a, $bc, $stop) = ('a', 'bc', 's'); | |
1522 | # $stop is to stop '~~' deleting the whole line | |
1523 | formline $sfmt, $stop, $a, $bc; | |
1524 | my $exp = $^A; | |
1525 | $^A = ''; | |
1526 | ($a, $bc, $stop) = ('a', 'bc', 's'); | |
1527 | formline $fmt, $stop, $a, $bc; | |
1528 | my $got = $^A; | |
1529 | $^A = ''; | |
1530 | $fmt =~ s/\n/\\n/; | |
1531 | ::is($got, $exp, "chop munging: [$fmt]"); | |
1532 | } | |
1533 | } | |
1534 | } | |
3808a683 DM |
1535 | } |
1536 | ||
f5ada144 DM |
1537 | # check that '~ (delete current line if empty) works when |
1538 | # the target gets upgraded to uft8 (and re-allocated) midstream. | |
1539 | ||
1540 | { | |
1541 | my $format = "\x{100}@~\n"; # format is utf8 | |
1542 | # this target is not utf8, but will expand (and get reallocated) | |
1543 | # when upgraded to utf8. | |
1544 | my $orig = "\x80\x81\x82"; | |
1545 | local $^A = $orig; | |
1546 | my $empty = ""; | |
1547 | formline $format, $empty; | |
1548 | is $^A , $orig, "~ and realloc"; | |
1549 | ||
1550 | # check similarly that trailing blank removal works ok | |
1551 | ||
1552 | $format = "@<\n\x{100}"; # format is utf8 | |
1553 | chop $format; | |
1554 | $orig = " "; | |
1555 | $^A = $orig; | |
1556 | formline $format, " "; | |
1557 | is $^A, "$orig\n", "end-of-line blanks and realloc"; | |
26e935cf DM |
1558 | |
1559 | # and check this doesn't overflow the buffer | |
1560 | ||
1561 | local $^A = ''; | |
1562 | $format = "@* @####\n"; | |
1563 | $orig = "x" x 100 . "\n"; | |
1564 | formline $format, $orig, 12345; | |
1565 | is $^A, ("x" x 100) . " 12345\n", "\@* doesn't overflow"; | |
76912796 | 1566 | |
e452bf1c DM |
1567 | # ...nor this (RT #130703). |
1568 | # Under 'use bytes', the two bytes (c2, 80) making up each \x80 char | |
1569 | # each get expanded to two bytes (so four in total per \x80 char); the | |
1570 | # buffer growth wasn't accounting for this doubling in size | |
1571 | ||
1572 | { | |
1573 | local $^A = ''; | |
1574 | my $format = "X\n\x{100}" . ("\x80" x 200); | |
1575 | my $expected = $format; | |
1576 | utf8::encode($expected); | |
1577 | use bytes; | |
1578 | formline($format); | |
1579 | is $^A, $expected, "RT #130703"; | |
1580 | } | |
1581 | ||
f62fd06d DM |
1582 | # further buffer overflows with RT #130703 |
1583 | ||
1584 | { | |
1585 | local $^A = ''; | |
1586 | my $n = 200; | |
1587 | my $long = 'x' x 300; | |
1588 | my $numf = ('@###' x $n); | |
1589 | my $expected = $long . "\n" . (" 1" x $n); | |
1590 | formline("@*\n$numf", $long, ('1') x $n); | |
1591 | ||
1592 | is $^A, $expected, "RT #130703 part 2"; | |
1593 | } | |
1594 | ||
e452bf1c | 1595 | |
76912796 DM |
1596 | # make sure it can cope with formats > 64k |
1597 | ||
1598 | $format = 'x' x 65537; | |
1599 | $^A = ''; | |
1600 | formline $format; | |
1601 | # don't use 'is' here, as the diag output will be too long! | |
1602 | ok $^A eq $format, ">64K"; | |
f5ada144 DM |
1603 | } |
1604 | ||
3808a683 | 1605 | |
d3d1232e NC |
1606 | SKIP: { |
1607 | skip_if_miniperl('miniperl does not support scalario'); | |
60fe2d11 | 1608 | my $buf = ""; |
fda0c190 MB |
1609 | open my $fh, ">", \$buf; |
1610 | my $old_fh = select $fh; | |
1611 | local $~ = "CmT"; | |
1612 | write; | |
1613 | select $old_fh; | |
1614 | close $fh; | |
1615 | is $buf, "ok $test\n", "write to duplicated format"; | |
1616 | } | |
1617 | ||
64eff8b7 DM |
1618 | format caret_A_test_TOP = |
1619 | T | |
1620 | . | |
1621 | ||
1622 | format caret_A_test = | |
1623 | L1 | |
1624 | L2 | |
1625 | L3 | |
1626 | L4 | |
1627 | . | |
1628 | ||
1629 | SKIP: { | |
1630 | skip_if_miniperl('miniperl does not support scalario'); | |
1631 | my $buf = ""; | |
1632 | open my $fh, ">", \$buf; | |
1633 | my $old_fh = select $fh; | |
1634 | local $^ = "caret_A_test_TOP"; | |
1635 | local $~ = "caret_A_test"; | |
1636 | local $= = 3; | |
1637 | local $^A = "A1\nA2\nA3\nA4\n"; | |
1638 | write; | |
1639 | select $old_fh; | |
1640 | close $fh; | |
1641 | is $buf, "T\nA1\nA2\n\fT\nA3\nA4\n\fT\nL1\nL2\n\fT\nL3\nL4\n", | |
1642 | "assign to ^A sets FmLINES"; | |
1643 | } | |
1644 | ||
ee6d2783 NC |
1645 | fresh_perl_like(<<'EOP', qr/^Format STDOUT redefined at/, {stderr => 1}, '#64562 - Segmentation fault with redefined formats and warnings'); |
1646 | #!./perl | |
1647 | ||
1648 | use strict; | |
1649 | use warnings; # crashes! | |
1650 | ||
1651 | format = | |
1652 | . | |
1653 | ||
1654 | write; | |
1655 | ||
1656 | format = | |
1657 | . | |
1658 | ||
1659 | write; | |
1660 | EOP | |
1661 | ||
37ffbfcc NC |
1662 | fresh_perl_is(<<'EOP', ">ARRAY<\ncrunch_eth\n", {stderr => 1}, '#79532 - formline coerces its arguments'); |
1663 | use strict; | |
1664 | use warnings; | |
1665 | my $zamm = ['crunch_eth']; | |
1666 | formline $zamm; | |
1667 | printf ">%s<\n", ref $zamm; | |
1668 | print "$zamm->[0]\n"; | |
1669 | EOP | |
1670 | ||
86191aed TC |
1671 | # [perl #129125] - detected by -fsanitize=address or valgrind |
1672 | # the compiled format would be freed when the format string was modified | |
1673 | # by the chop operator | |
1674 | fresh_perl_is(<<'EOP', "^", { stderr => 1 }, '#129125 - chop on format'); | |
1675 | my $x = '^@'; | |
1676 | formline$x=>$x; | |
1677 | print $^A; | |
1678 | EOP | |
1679 | ||
1680 | fresh_perl_is(<<'EOP', '<^< xx AA><xx ^<><>', { stderr => 1 }, '#129125 - chop on format, later values'); | |
1681 | my $x = '^< xx ^<'; | |
1682 | my $y = 'AA'; | |
1683 | formline $x => $x, $y; | |
1684 | print "<$^A><$x><$y>"; | |
1685 | EOP | |
1686 | ||
1687 | ||
8e4ecf23 JL |
1688 | # [perl #73690] |
1689 | ||
1690 | select +(select(RT73690), do { | |
1691 | open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
1692 | format RT73690 = | |
1693 | @<< @<< | |
1694 | 11, 22 | |
1695 | . | |
1696 | ||
1697 | my @ret; | |
591097e0 | 1698 | |
8e4ecf23 JL |
1699 | @ret = write; |
1700 | is(scalar(@ret), 1); | |
1701 | ok($ret[0]); | |
1702 | @ret = scalar(write); | |
1703 | is(scalar(@ret), 1); | |
1704 | ok($ret[0]); | |
1705 | @ret = write(RT73690); | |
1706 | is(scalar(@ret), 1); | |
1707 | ok($ret[0]); | |
1708 | @ret = scalar(write(RT73690)); | |
1709 | is(scalar(@ret), 1); | |
1710 | ok($ret[0]); | |
1711 | ||
591097e0 JL |
1712 | @ret = ('a', write, 'z'); |
1713 | is(scalar(@ret), 3); | |
1714 | is($ret[0], 'a'); | |
1715 | ok($ret[1]); | |
1716 | is($ret[2], 'z'); | |
1717 | @ret = ('b', scalar(write), 'y'); | |
1718 | is(scalar(@ret), 3); | |
1719 | is($ret[0], 'b'); | |
1720 | ok($ret[1]); | |
1721 | is($ret[2], 'y'); | |
1722 | @ret = ('c', write(RT73690), 'x'); | |
1723 | is(scalar(@ret), 3); | |
1724 | is($ret[0], 'c'); | |
1725 | ok($ret[1]); | |
1726 | is($ret[2], 'x'); | |
1727 | @ret = ('d', scalar(write(RT73690)), 'w'); | |
1728 | is(scalar(@ret), 3); | |
1729 | is($ret[0], 'd'); | |
1730 | ok($ret[1]); | |
1731 | is($ret[2], 'w'); | |
1732 | ||
1733 | @ret = do { write; 'foo' }; | |
1734 | is(scalar(@ret), 1); | |
1735 | is($ret[0], 'foo'); | |
1736 | @ret = do { scalar(write); 'bar' }; | |
1737 | is(scalar(@ret), 1); | |
1738 | is($ret[0], 'bar'); | |
1739 | @ret = do { write(RT73690); 'baz' }; | |
1740 | is(scalar(@ret), 1); | |
1741 | is($ret[0], 'baz'); | |
1742 | @ret = do { scalar(write(RT73690)); 'quux' }; | |
1743 | is(scalar(@ret), 1); | |
1744 | is($ret[0], 'quux'); | |
1745 | ||
1746 | @ret = ('a', do { write; 'foo' }, 'z'); | |
1747 | is(scalar(@ret), 3); | |
1748 | is($ret[0], 'a'); | |
1749 | is($ret[1], 'foo'); | |
1750 | is($ret[2], 'z'); | |
1751 | @ret = ('b', do { scalar(write); 'bar' }, 'y'); | |
1752 | is(scalar(@ret), 3); | |
1753 | is($ret[0], 'b'); | |
1754 | is($ret[1], 'bar'); | |
1755 | is($ret[2], 'y'); | |
1756 | @ret = ('c', do { write(RT73690); 'baz' }, 'x'); | |
1757 | is(scalar(@ret), 3); | |
1758 | is($ret[0], 'c'); | |
1759 | is($ret[1], 'baz'); | |
1760 | is($ret[2], 'x'); | |
1761 | @ret = ('d', do { scalar(write(RT73690)); 'quux' }, 'w'); | |
1762 | is(scalar(@ret), 3); | |
1763 | is($ret[0], 'd'); | |
1764 | is($ret[1], 'quux'); | |
1765 | is($ret[2], 'w'); | |
1766 | ||
8e4ecf23 JL |
1767 | close RT73690 or die "Could not close: $!"; |
1768 | })[0]; | |
1769 | ||
1770 | select +(select(RT73690_2), do { | |
1771 | open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
1772 | format RT73690_2 = | |
1773 | @<< @<< | |
1774 | return | |
1775 | . | |
1776 | ||
1777 | my @ret; | |
591097e0 | 1778 | |
8e4ecf23 JL |
1779 | @ret = write; |
1780 | is(scalar(@ret), 1); | |
1781 | ok(!$ret[0]); | |
1782 | @ret = scalar(write); | |
1783 | is(scalar(@ret), 1); | |
1784 | ok(!$ret[0]); | |
1785 | @ret = write(RT73690_2); | |
1786 | is(scalar(@ret), 1); | |
1787 | ok(!$ret[0]); | |
1788 | @ret = scalar(write(RT73690_2)); | |
1789 | is(scalar(@ret), 1); | |
1790 | ok(!$ret[0]); | |
1791 | ||
591097e0 JL |
1792 | @ret = ('a', write, 'z'); |
1793 | is(scalar(@ret), 3); | |
1794 | is($ret[0], 'a'); | |
1795 | ok(!$ret[1]); | |
1796 | is($ret[2], 'z'); | |
1797 | @ret = ('b', scalar(write), 'y'); | |
1798 | is(scalar(@ret), 3); | |
1799 | is($ret[0], 'b'); | |
1800 | ok(!$ret[1]); | |
1801 | is($ret[2], 'y'); | |
1802 | @ret = ('c', write(RT73690_2), 'x'); | |
1803 | is(scalar(@ret), 3); | |
1804 | is($ret[0], 'c'); | |
1805 | ok(!$ret[1]); | |
1806 | is($ret[2], 'x'); | |
1807 | @ret = ('d', scalar(write(RT73690_2)), 'w'); | |
1808 | is(scalar(@ret), 3); | |
1809 | is($ret[0], 'd'); | |
1810 | ok(!$ret[1]); | |
1811 | is($ret[2], 'w'); | |
1812 | ||
1813 | @ret = do { write; 'foo' }; | |
1814 | is(scalar(@ret), 1); | |
1815 | is($ret[0], 'foo'); | |
1816 | @ret = do { scalar(write); 'bar' }; | |
1817 | is(scalar(@ret), 1); | |
1818 | is($ret[0], 'bar'); | |
1819 | @ret = do { write(RT73690_2); 'baz' }; | |
1820 | is(scalar(@ret), 1); | |
1821 | is($ret[0], 'baz'); | |
1822 | @ret = do { scalar(write(RT73690_2)); 'quux' }; | |
1823 | is(scalar(@ret), 1); | |
1824 | is($ret[0], 'quux'); | |
1825 | ||
1826 | @ret = ('a', do { write; 'foo' }, 'z'); | |
1827 | is(scalar(@ret), 3); | |
1828 | is($ret[0], 'a'); | |
1829 | is($ret[1], 'foo'); | |
1830 | is($ret[2], 'z'); | |
1831 | @ret = ('b', do { scalar(write); 'bar' }, 'y'); | |
1832 | is(scalar(@ret), 3); | |
1833 | is($ret[0], 'b'); | |
1834 | is($ret[1], 'bar'); | |
1835 | is($ret[2], 'y'); | |
1836 | @ret = ('c', do { write(RT73690_2); 'baz' }, 'x'); | |
1837 | is(scalar(@ret), 3); | |
1838 | is($ret[0], 'c'); | |
1839 | is($ret[1], 'baz'); | |
1840 | is($ret[2], 'x'); | |
1841 | @ret = ('d', do { scalar(write(RT73690_2)); 'quux' }, 'w'); | |
1842 | is(scalar(@ret), 3); | |
1843 | is($ret[0], 'd'); | |
1844 | is($ret[1], 'quux'); | |
1845 | is($ret[2], 'w'); | |
1846 | ||
8e4ecf23 JL |
1847 | close RT73690_2 or die "Could not close: $!"; |
1848 | })[0]; | |
1849 | ||
ee23553f FC |
1850 | open(UNDEF, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
1851 | select +(select(UNDEF), $~ = "UNDEFFORMAT")[0]; | |
1852 | format UNDEFFORMAT = | |
1853 | @ | |
1854 | undef *UNDEFFORMAT | |
1855 | . | |
1856 | write UNDEF; | |
1857 | pass "active format cannot be freed"; | |
c782dc1d FC |
1858 | |
1859 | select +(select(UNDEF), $~ = "UNDEFFORMAT2")[0]; | |
1860 | format UNDEFFORMAT2 = | |
1861 | @ | |
1862 | close UNDEF or die "Could not close: $!"; undef *UNDEF | |
1863 | . | |
1864 | write UNDEF; | |
1865 | pass "freeing current handle in format"; | |
1866 | undef $^A; | |
ee23553f | 1867 | |
7c70caa5 FC |
1868 | ok !eval q| |
1869 | format foo { | |
1870 | @<<< | |
1871 | $a | |
1872 | } | |
1873 | ;1 | |
1874 | |, 'format foo { ... } is not allowed'; | |
1875 | ||
1876 | ok !eval q| | |
1877 | format = | |
1878 | @<<< | |
1879 | } | |
1880 | ;1 | |
1881 | |, 'format = ... } is not allowed'; | |
1882 | ||
64a40898 FC |
1883 | open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
1884 | format NEST = | |
1885 | @<<< | |
1886 | { | |
1887 | my $birds = "birds"; | |
1888 | local *NEST = *BIRDS{FORMAT}; | |
1889 | write NEST; | |
1890 | format BIRDS = | |
1891 | @<<<<< | |
1892 | $birds; | |
1893 | . | |
1894 | "nest" | |
1895 | } | |
1896 | . | |
1897 | write NEST; | |
1898 | close NEST or die "Could not close: $!"; | |
1899 | is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats'; | |
1900 | ||
2c658e55 FC |
1901 | # A compilation error should not create a format |
1902 | eval q| | |
1903 | format ERROR = | |
1904 | @ | |
1905 | @_ =~ s/// | |
1906 | . | |
1907 | |; | |
1908 | eval { write ERROR }; | |
1909 | like $@, qr'Undefined format', | |
1910 | 'formats with compilation errors are not created'; | |
1911 | ||
6c7ae946 FC |
1912 | # This syntax error used to cause a crash, double free, or a least |
1913 | # a bad read. | |
1914 | # See the long-winded explanation at: | |
1915 | # https://rt.perl.org/rt3/Ticket/Display.html?id=43425#txn-1144500 | |
1916 | eval q| | |
1917 | format = | |
1918 | @ | |
1919 | use;format | |
1920 | strict | |
1921 | . | |
1922 | |; | |
1923 | pass('no crash with invalid use/format inside format'); | |
1924 | ||
ee23553f | 1925 | |
705fe0e5 FC |
1926 | # Low-precedence operators on argument line |
1927 | format AND = | |
1928 | @ | |
1929 | 0 and die | |
1930 | . | |
1931 | $- = $=; | |
1932 | ok eval { local $~ = "AND"; print "# "; write; 1 }, | |
1933 | "low-prec ops on arg line" or diag $@; | |
1934 | ||
1935 | # Anonymous hashes | |
1936 | open(HASH, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
1937 | format HASH = | |
1938 | @<<< | |
1939 | ${{qw[ Sun 0 Mon 1 Tue 2 Wed 3 Thu 4 Fri 5 Sat 6 ]}}{"Wed"} | |
1940 | . | |
1941 | write HASH; | |
1942 | close HASH or die "Could not close: $!"; | |
1943 | is cat('Op_write.tmp'), "3\n", 'anonymous hashes'; | |
1944 | ||
f60e6763 FC |
1945 | open(HASH2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; |
1946 | format HASH2 = | |
1947 | @<<< | |
1948 | +{foo=>"bar"} | |
1949 | . | |
1950 | write HASH2; | |
1951 | close HASH2 or die "Could not close: $!"; | |
1952 | is cat('Op_write.tmp'), "HASH\n", '+{...} is interpreted as anon hash'; | |
1953 | ||
1954 | # Anonymous hashes | |
1955 | open(BLOCK, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
1956 | format BLOCK = | |
1957 | @<<< @<<< | |
1958 | {foo=>"bar"} # this is a block, not a hash! | |
1959 | . | |
1960 | write BLOCK; | |
1961 | close BLOCK or die "Could not close: $!"; | |
1962 | is cat('Op_write.tmp'), "foo bar\n", 'initial { is always BLOCK'; | |
1963 | ||
705fe0e5 FC |
1964 | # pragmata inside argument line |
1965 | open(STRICT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; | |
1966 | format STRICT = | |
1967 | @<<< | |
1968 | no strict; $foo | |
1969 | . | |
1970 | $::foo = 'oof::$'; | |
1971 | write STRICT; | |
1972 | close STRICT or die "Could not close: $!"; | |
1973 | is cat('Op_write.tmp'), "oof:\n", 'pragmata on format line'; | |
1974 | ||
7c93c29b FC |
1975 | SKIP: { |
1976 | skip "no weak refs" unless eval { require Scalar::Util }; | |
1977 | sub Potshriggley { | |
1978 | format Potshriggley = | |
1979 | . | |
1980 | } | |
1981 | Scalar::Util::weaken(my $x = *Potshriggley{FORMAT}); | |
1982 | undef *Potshriggley; | |
1983 | is $x, undef, 'formats in subs do not leak'; | |
7c93c29b FC |
1984 | } |
1985 | ||
fcaef4dc TC |
1986 | fresh_perl_is(<<'EOP', <<'EXPECT', |
1987 | use warnings 'syntax' ; | |
1988 | format STDOUT = | |
1989 | ^*|^* | |
1990 | my $x = q/dd/, $x | |
1991 | . | |
1992 | write; | |
1993 | EOP | |
1994 | dd| | |
1995 | EXPECT | |
1996 | { stderr => 1 }, '#123245 panic in sv_chop'); | |
1997 | ||
1998 | fresh_perl_is(<<'EOP', <<'EXPECT', | |
1999 | use warnings 'syntax' ; | |
2000 | format STDOUT = | |
2001 | ^*|^* | |
2002 | my $x = q/dd/ | |
2003 | . | |
2004 | write; | |
2005 | EOP | |
2006 | Not enough format arguments at - line 4. | |
2007 | dd| | |
2008 | EXPECT | |
2009 | { stderr => 1 }, '#123245 different panic in sv_chop'); | |
705fe0e5 | 2010 | |
62db6ea5 TC |
2011 | fresh_perl_is(<<'EOP', <<'EXPECT', |
2012 | format STDOUT = | |
2013 | # x at the end to make the spaces visible | |
2014 | @... x | |
2015 | q/a/ | |
2016 | . | |
2017 | write; | |
2018 | EOP | |
2019 | a x | |
2020 | EXPECT | |
2021 | { stderr => 1 }, '#123538 crash in FF_MORE'); | |
2022 | ||
a4031a72 Z |
2023 | { |
2024 | $^A = ""; | |
2025 | my $a = *globcopy; | |
2026 | my $r = eval { formline "^<<", $a }; | |
2027 | is $@, ""; | |
2028 | ok $r, "^ format with glob copy"; | |
2029 | is $^A, "*ma", "^ format with glob copy"; | |
2030 | is $a, "in::globcopy", "^ format with glob copy"; | |
2031 | } | |
2032 | ||
2033 | { | |
2034 | $^A = ""; | |
2035 | my $r = eval { formline "^<<", *realglob }; | |
2036 | like $@, qr/\AModification of a read-only value attempted /; | |
2037 | is $r, undef, "^ format with real glob"; | |
2038 | is $^A, "*ma", "^ format with real glob"; | |
2039 | is ref(\*realglob), "GLOB"; | |
2040 | } | |
2041 | ||
2042 | $^A = ""; | |
59a08c76 | 2043 | |
dd314e1c TC |
2044 | # [perl #130722] assertion failure |
2045 | fresh_perl_is('for(1..2){formline*0}', '', { stderr => 1 } , "#130722 - assertion failure"); | |
2046 | ||
2027357e NC |
2047 | ############################# |
2048 | ## Section 4 | |
2049 | ## Add new tests *above* here | |
2050 | ############################# | |
2051 | ||
f5b75c1c NC |
2052 | # scary format testing from H.Merijn Brand |
2053 | ||
2054 | # Just a complete test for format, including top-, left- and bottom marging | |
2055 | # and format detection through glob entries | |
2056 | ||
7b903762 | 2057 | if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || |
f5b75c1c NC |
2058 | ($^O eq 'os2' and not eval '$OS2::can_fork')) { |
2059 | $test = curr_test(); | |
2060 | SKIP: { | |
2061 | skip "'|-' and '-|' not supported", $tests - $test + 1; | |
2062 | } | |
2063 | exit(0); | |
2064 | } | |
2065 | ||
2066 | ||
0bd0581c DM |
2067 | $^ = "STDOUT_TOP"; |
2068 | $= = 7; # Page length | |
2069 | $- = 0; # Lines left | |
9ccde9ea JH |
2070 | my $ps = $^L; $^L = ""; # Catch the page separator |
2071 | my $tm = 1; # Top margin (empty lines before first output) | |
2072 | my $bm = 2; # Bottom marging (empty lines between last text and footer) | |
2073 | my $lm = 4; # Left margin (indent in spaces) | |
2074 | ||
68ba3c2c DM |
2075 | # ----------------------------------------------------------------------- |
2076 | # | |
2077 | # execute the rest of the script in a child process. The parent reads the | |
2078 | # output from the child and compares it with <DATA>. | |
2079 | ||
2080 | my @data = <DATA>; | |
2081 | ||
2082 | select ((select (STDOUT), $| = 1)[0]); # flush STDOUT | |
2083 | ||
2084 | my $opened = open FROM_CHILD, "-|"; | |
2085 | unless (defined $opened) { | |
6108250c NC |
2086 | fail "open gave $!"; |
2087 | exit 0; | |
68ba3c2c DM |
2088 | } |
2089 | ||
2090 | if ($opened) { | |
2091 | # in parent here | |
2092 | ||
6108250c | 2093 | pass 'open'; |
9ccde9ea | 2094 | my $s = " " x $lm; |
68ba3c2c DM |
2095 | while (<FROM_CHILD>) { |
2096 | unless (@data) { | |
6108250c | 2097 | fail 'too much output'; |
68ba3c2c DM |
2098 | exit; |
2099 | } | |
9ccde9ea | 2100 | s/^/$s/; |
68ba3c2c | 2101 | my $exp = shift @data; |
6108250c | 2102 | is $_, $exp; |
9ccde9ea | 2103 | } |
68ba3c2c | 2104 | close FROM_CHILD; |
6108250c | 2105 | is "@data", "", "correct length of output"; |
68ba3c2c DM |
2106 | exit; |
2107 | } | |
2108 | ||
2109 | # in child here | |
6108250c | 2110 | $::NO_ENDING = 1; |
68ba3c2c DM |
2111 | |
2112 | select ((select (STDOUT), $| = 1)[0]); | |
9ccde9ea JH |
2113 | $tm = "\n" x $tm; |
2114 | $= -= $bm + 1; # count one for the trailing "----" | |
2115 | my $lastmin = 0; | |
2116 | ||
2117 | my @E; | |
2118 | ||
2119 | sub wryte | |
2120 | { | |
2121 | $lastmin = $-; | |
2122 | write; | |
2123 | } # wryte; | |
2124 | ||
2125 | sub footer | |
2126 | { | |
2127 | $% == 1 and return ""; | |
2128 | ||
2129 | $lastmin < $= and print "\n" x $lastmin; | |
2130 | print "\n" x $bm, "----\n", $ps; | |
2131 | $lastmin = $-; | |
2132 | ""; | |
2133 | } # footer | |
2134 | ||
2135 | # Yes, this is sick ;-) | |
2136 | format TOP = | |
2137 | @* ~ | |
2138 | @{[footer]} | |
2139 | @* ~ | |
2140 | $tm | |
2141 | . | |
2142 | ||
9ccde9ea JH |
2143 | format ENTRY = |
2144 | @ @<<<<~~ | |
2145 | @{(shift @E)||["",""]} | |
2146 | . | |
2147 | ||
2148 | format EOR = | |
2149 | - ----- | |
2150 | . | |
2151 | ||
2152 | sub has_format ($) | |
2153 | { | |
2154 | my $fmt = shift; | |
2155 | exists $::{$fmt} or return 0; | |
2156 | $^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT}; | |
2157 | open my $null, "> /dev/null" or die; | |
2158 | my $fh = select $null; | |
2159 | local $~ = $fmt; | |
2160 | eval "write"; | |
2161 | select $fh; | |
2162 | $@?0:1; | |
2163 | } # has_format | |
2164 | ||
d57f9278 | 2165 | $^ = has_format ("TOP") ? "TOP" : "EMPTY"; |
9ccde9ea JH |
2166 | has_format ("ENTRY") or die "No format defined for ENTRY"; |
2167 | foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ], | |
2168 | [ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) { | |
2169 | @E = @$e; | |
2170 | local $~ = "ENTRY"; | |
2171 | wryte; | |
2172 | has_format ("EOR") or next; | |
2173 | local $~ = "EOR"; | |
2174 | wryte; | |
2175 | } | |
2176 | if (has_format ("EOF")) { | |
2177 | local $~ = "EOF"; | |
2178 | wryte; | |
2179 | } | |
2180 | ||
2181 | close STDOUT; | |
2182 | ||
ea42cebc | 2183 | # That was test 48. |
9ccde9ea JH |
2184 | |
2185 | __END__ | |
2186 | ||
2187 | 1 Test1 | |
2188 | 2 Test2 | |
2189 | 3 Test3 | |
2190 | ||
2191 | ||
2192 | ---- | |
2193 | \f | |
2194 | 4 Test4 | |
2195 | 5 Test5 | |
2196 | 6 Test6 | |
2197 | ||
2198 | ||
2199 | ---- | |
2200 | \f | |
2201 | 7 Test7 | |
2202 | - ----- | |
2203 | ||
2204 | ||
2205 | ||
2206 | ---- | |
2207 | \f | |
2208 | 1 1tseT | |
2209 | 2 2tseT | |
2210 | 3 3tseT | |
2211 | ||
2212 | ||
2213 | ---- | |
2214 | \f | |
2215 | 4 4tseT | |
2216 | 5 5tseT | |
2217 | - ----- |