This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #78550] Fix bad assertion in toke.c:start_subparse
[perl5.git] / t / comp / form_scope.t
CommitLineData
421f30ed 1#!./perl
421f30ed 2
f2ead8b8 3print "1..10\n";
421f30ed 4
e09ac076 5# Tests bug #22977. Test case from Dave Mitchell.
421f30ed
Z
6sub f ($);
7sub f ($) {
8my $test = $_[0];
9write;
10format STDOUT =
11ok @<<<<<<<
12$test
13.
14}
15
16f(1);
17f(2);
e09ac076
FC
18
19# A bug caused by the fix for #22977/50528
20sub foo {
21 sub bar {
22 # Fill the pad with alphabet soup, to give the closed-over variable a
23 # high padoffset (more likely to trigger the bug and crash).
24 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
25 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
26 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
27 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
28 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
29 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
30 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
31 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
32 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
33 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
34 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
35 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
36 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
37 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
38 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
39 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
40 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
41 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
42 my $x;
43 format STDOUT2 =
44@<<<<<<
45"ok 3".$x # $x is not available, but this should not crash
46.
47 }
48}
49*STDOUT = *STDOUT2{FORMAT};
50undef *bar;
51write;
52
af41786f
FC
53# A regression introduced in 5.10; format cloning would close over the
54# variables in the currently-running sub (the main CV in this test) if the
55# outer sub were an inactive closure.
56sub baz {
57 my $a;
58 sub {
59 $a;
60 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t)}
61 my $x;
62 format STDOUT3 =
63@<<<<<<<<<<<<<<<<<<<<<<<<<
64defined $x ? "not ok 4 - $x" : "ok 4"
65.
66 }
67}
68*STDOUT = *STDOUT3{FORMAT};
69{
70 local $^W = 1;
71 my $w;
72 local $SIG{__WARN__} = sub { $w = shift };
73 write;
74 print "not " unless $w =~ /^Variable "\$x" is not available at/;
75 print "ok 5 - closure var not available when outer sub is inactive\n";
76}
70794f7b
FC
77
78# Formats inside closures should close over the topmost clone of the outer
79# sub on the call stack.
80# Tests will be out of sequence if the wrong sub is used.
81sub make_closure {
82 my $arg = shift;
83 sub {
84 shift == 0 and &$next(1), return;
85 my $x = "ok $arg";
86 format STDOUT4 =
87@<<<<<<<
88$x
89.
90 sub { write }->(); # separate sub, so as not to rely on it being the
91 } # currently-running sub
92}
93*STDOUT = *STDOUT4{FORMAT};
94$clo1 = make_closure 6;
95$clo2 = make_closure 7;
96$next = $clo1;
97&$clo2(0);
98$next = $clo2;
99&$clo1(0);
4a273b91 100
f2ead8b8
FC
101# Cloning a format whose outside has been undefined
102sub x {
103 {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)}
104 my $z;
105 format STDOUT6 =
106@<<<<<<<<<<<<<<<<<<<<<<<<<
107defined $z ? "not ok 8 - $z" : "ok 8"
108.
109}
110undef &x;
111*STDOUT = *STDOUT6{FORMAT};
112{
113 local $^W = 1;
114 my $w;
115 local $SIG{__WARN__} = sub { $w = shift };
116 write;
117 print "not " unless $w =~ /^Variable "\$z" is not available at/;
118 print "ok 9 - closure var not available when outer sub is undefined\n";
119}
120
9a715434
FC
121format start_subparse::assertion =
122@
123sub { }
124.
125# survived; no "print ok" necessary
126
4a273b91
FC
127# This is a variation of bug #22977, which crashes or fails an assertion
128# up to 5.16.
129# Keep this test last if you want test numbers to be sane.
130BEGIN { \&END }
131END {
f2ead8b8 132 my $test = "ok 10";
4a273b91
FC
133 *STDOUT = *STDOUT5{FORMAT};
134 write;
135 format STDOUT5 =
136@<<<<<<<
137$test
138.
139}