Skip to content

Commit

Permalink
make a new stub to clone into when pushing a new pad
Browse files Browse the repository at this point in the history
This previously put the same CV into the inner pad, so on a
recursive call into the owning sub, from this sub, this CV would
still be active, and the attempt to clone into the still busy CV
would throw.

Fixes Perl#18606
  • Loading branch information
tonycoz committed Oct 22, 2023
1 parent f8f432a commit c2e77d4
Show file tree
Hide file tree
Showing 2 changed files with 71 additions and 3 deletions.
15 changes: 13 additions & 2 deletions pad.c
Original file line number Diff line number Diff line change
Expand Up @@ -2460,8 +2460,19 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
|| PadnameIsSTATE(names[ix])
|| sigil == '&')
{
/* outer lexical or anon code */
sv = SvREFCNT_inc(oldpad[ix]);
SV *tmp = oldpad[ix];
if (sigil == '&' && SvTYPE(tmp) == SVt_PVCV
&& !PadnameOUTER(names[ix])
&& CvLEXICAL(tmp) && CvCLONED(tmp)
&& !PadnameIsOUR(names[ix])
&& !PadnameIsSTATE(names[ix])) {
/* lexical sub that needs cloning */
sv = newSV_type(SVt_PVCV);
}
else {
/* outer non-cloning lexical or anon code */
sv = SvREFCNT_inc(oldpad[ix]);
}
}
else { /* our own lexical */
if (sigil == '@')
Expand Down
59 changes: 58 additions & 1 deletion t/op/lexsub.t
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,8 @@ BEGIN {
*bar::is = *is;
*bar::like = *like;
}
plan 152;

plan 156;

# -------------------- our -------------------- #

Expand Down Expand Up @@ -979,3 +980,59 @@ is join("-", qw(aa bb), do { my sub lleexx; 123 }, qw(cc dd)),
}
nested();
}

SKIP:
{
# github #18606
sub rec1 {
my $x = shift;
my sub b { $x };
rec1(2) if $x == 1;
return b();
}
is(rec1(1), 1, "check recursively defined lexical sub is lexical");

sub rec2 {
my ($x, $name) = @_;

my sub b;
if ($x) {
# provides definition for my sub b
sub b { $name }
}
rec2($x-1, "inner") if $x;

b();
}
is(rec2(0, "outer"), "outer", "check again");
is(rec2(1, "outer"), "outer", "check some more");

fresh_perl_like(<<'EOS', qr/result=103/, {}, "test code from #18606");
use strict; use warnings; use feature qw/say state/;
say "Perl version $^V";
sub process($;$) {
my ($value, $callback) = @_;
say "### process($value,", ($callback//"undef"), ")";
my sub inner {
if ($callback) {
return $callback->($value+1);
} else {
return $value+1;
}
}
inner();
}
my $result =
process(1, sub{
my $arg = shift;
say "# callback called with arg $arg";
process($arg+100);
});
say "result=", ($result//"undef");
EOS

}

0 comments on commit c2e77d4

Please sign in to comment.