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