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