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
1 #!./perl
2
3 print "1..10\n";
4
5 # Tests bug #22977.  Test case from Dave Mitchell.
6 sub f ($);
7 sub f ($) {
8 my $test = $_[0];
9 write;
10 format STDOUT =
11 ok @<<<<<<<
12 $test
13 .
14 }
15
16 f(1);
17 f(2);
18
19 # A bug caused by the fix for #22977/50528
20 sub 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};
50 undef *bar;
51 write;
52
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.
56 sub 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 @<<<<<<<<<<<<<<<<<<<<<<<<<
64 defined $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 }
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.
81 sub 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);
100
101 # Cloning a format whose outside has been undefined
102 sub 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 @<<<<<<<<<<<<<<<<<<<<<<<<<
107 defined $z ? "not ok 8 - $z" : "ok 8"
108 .
109 }
110 undef &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
121 format start_subparse::assertion =
122 @
123 sub { }
124 .
125 # survived; no "print ok" necessary
126
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.
130 BEGIN { \&END }
131 END {
132   my $test = "ok 10";
133   *STDOUT = *STDOUT5{FORMAT};
134   write;
135   format STDOUT5 =
136 @<<<<<<<
137 $test
138 .
139 }