1#!./perl 2 3print "1..14\n"; 4 5# Tests bug #22977. Test case from Dave Mitchell. 6sub f ($); 7sub f ($) { 8my $test = $_[0]; 9write; 10format STDOUT = 11ok @<<<<<<< 12$test 13. 14} 15 16f(1); 17f(2); 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 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} 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); 100 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 121format STDOUT7 = 122@<<<<<<<<<<<<<<<<<<<<<<<<<<< 123do { my $x = "ok 10 - closure inside format"; sub { $x }->() } 124. 125*STDOUT = *STDOUT7{FORMAT}; 126write; 127 128$testn = 12; 129format STDOUT8 = 130@<<<< - recursive formats 131do { my $t = "ok " . $testn--; write if $t =~ 12; $t} 132. 133*STDOUT = *STDOUT8{FORMAT}; 134write; 135 136sub _13 { 137 my $x; 138format STDOUT13 = 139@* - formats closing over redefined subs (got @*) 140ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13", ref \$x; 141. 142} 143undef &_13; 144eval 'sub _13 { my @x; write }'; 145*STDOUT = *STDOUT13{FORMAT}; 146_13(); 147 148# This is a variation of bug #22977, which crashes or fails an assertion 149# up to 5.16. 150# Keep this test last if you want test numbers to be sane. 151BEGIN { \&END } 152END { 153 my $test = "ok 14"; 154 *STDOUT = *STDOUT5{FORMAT}; 155 write; 156 format STDOUT5 = 157@<<<<<<< 158$test 159. 160} 161