In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e0c6a6b8c9a5470601df2e25f77f2422fb3f2ea5?hp=8a737443e3c53597024b13b97da37ea640b9d851>
- Log ----------------------------------------------------------------- commit e0c6a6b8c9a5470601df2e25f77f2422fb3f2ea5 Author: Father Chrysostomos <[email protected]> Date: Sun Jan 11 20:39:03 2015 -0800 Confused cloning of nested state subs use feature 'lexical_subs','state'; no warnings 'experimental'; my $sub = sub{ state sub sb4; state sub a { state $x = 42; sub sb4 { $x; } } a(); print sb4(), "\n"; }; $sub->(); The output: Bizarre copy of CODE in subroutine exit at - line 10. The sb4 sub was trying to close over the wrong pad; namely, the one belonging to the anonymous sub. ----------------------------------------------------------------------- Summary of changes: pad.c | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++-------- t/op/lexsub.t | 41 +++++++++++++++++++++++++++++- 2 files changed, 112 insertions(+), 11 deletions(-) diff --git a/pad.c b/pad.c index 4e675fa..aa63fde 100644 --- a/pad.c +++ b/pad.c @@ -1940,10 +1940,11 @@ the immediately surrounding code. =cut */ -static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside); +static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned); static CV * -S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) +S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, + bool newcv) { I32 ix; PADLIST* const protopadlist = CvPADLIST(proto); @@ -1955,7 +1956,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) const I32 fpad = AvFILLp(protopad); SV** outpad; long depth; - bool subclones = FALSE; + U32 subclones = 0; + bool trouble = FALSE; assert(!CvUNIQUE(proto)); @@ -2042,7 +2044,9 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) second pass. */ if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) { assert(SvTYPE(ppad[ix]) == SVt_PVCV); - subclones = 1; + subclones ++; + if (CvOUTSIDE(ppad[ix]) != proto) + trouble = TRUE; sv = newSV_type(SVt_PVCV); CvLEXICAL_on(sv); } @@ -2088,12 +2092,70 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) } if (subclones) - for (ix = fpad; ix > 0; ix--) { + { + if (trouble || cloned) { + /* Uh-oh, we have trouble! At least one of the state subs here + has its CvOUTSIDE pointer pointing somewhere unexpected. It + could be pointing to another state protosub that we are + about to clone. So we have to track which sub clones come + from which protosubs. If the CvOUTSIDE pointer for a parti- + cular sub points to something we have not cloned yet, we + delay cloning it. We must loop through the pad entries, + until we get a full pass with no cloning. If any uncloned + subs remain (probably nested inside anonymous or âmyâ subs), + then they get cloned in a final pass. + */ + bool cloned_in_this_pass; + if (!cloned) + cloned = (HV *)sv_2mortal((SV *)newHV()); + do { + cloned_in_this_pass = FALSE; + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + { + CV * const protokey = CvOUTSIDE(ppad[ix]); + CV ** const cvp = protokey == proto + ? &cv + : (CV **)hv_fetch(cloned, (char *)&protokey, + sizeof(CV *), 0); + if (cvp && *cvp) { + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + *cvp, cloned); + hv_store(cloned, (char *)&ppad[ix], + sizeof(CV *), + SvREFCNT_inc_simple_NN(PL_curpad[ix]), + 0); + subclones--; + cloned_in_this_pass = TRUE; + } + } + } + } while (cloned_in_this_pass); + if (subclones) + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + CvOUTSIDE(ppad[ix]), cloned); + } + } + else for (ix = fpad; ix > 0; ix--) { PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; if (name && name != &PL_padname_undef && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name)) - S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv); + S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, + NULL); } + } if (newcv) SvREFCNT_inc_simple_void_NN(cv); LEAVE; @@ -2186,7 +2248,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) } static CV * -S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) +S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) { #ifdef USE_ITHREADS dVAR; @@ -2221,7 +2283,7 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) mg_copy((SV *)proto, (SV *)cv, 0, 0); if (CvPADLIST(proto)) - cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv); + cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv); DEBUG_Xv( PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); @@ -2239,7 +2301,7 @@ Perl_cv_clone(pTHX_ CV *proto) PERL_ARGS_ASSERT_CV_CLONE; if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone"); - return S_cv_clone(aTHX_ proto, NULL, NULL); + return S_cv_clone(aTHX_ proto, NULL, NULL, NULL); } /* Called only by pp_clonecv */ @@ -2248,7 +2310,7 @@ Perl_cv_clone_into(pTHX_ CV *proto, CV *target) { PERL_ARGS_ASSERT_CV_CLONE_INTO; cv_undef(target); - return S_cv_clone(aTHX_ proto, target, NULL); + return S_cv_clone(aTHX_ proto, target, NULL, NULL); } /* diff --git a/t/op/lexsub.t b/t/op/lexsub.t index 2ba7635..b1b76e8 100644 --- a/t/op/lexsub.t +++ b/t/op/lexsub.t @@ -7,7 +7,7 @@ BEGIN { *bar::is = *is; *bar::like = *like; } -plan 148; +plan 151; # -------------------- Errors with feature disabled -------------------- # @@ -291,6 +291,45 @@ sub make_anon_with_state_sub{ 'state subs in anon subs are cloned'; is &$s(0), &$s(0), 'but only when the anon sub is cloned'; } +# Check that nested state subs close over variables properly +{ + is sub { + state sub a; + state sub b { + state sub c { + state $x = 42; + sub a { $x } + } + c(); + } + b(); + a(); + }->(), 42, 'state sub with body defined in doubly-nested state subs'; + is sub { + state sub a; + state sub b; + state sub c { + sub b { + state $x = 42; + sub a { $x } + } + } + b(); + a(); + }->(), 42, 'nested state subs declared in same scope'; + state $w; + local $SIG{__WARN__} = sub { $w .= shift }; + use warnings 'closure'; + my $sub = sub { + state sub a; + sub { + my $x; + sub a { $x } + } + }; + like $w, qr/Variable \"\$x\" is not available at /, + "unavailability warning when state closure is defined in anon sub"; +} { state sub BEGIN { exit }; pass 'state subs are never special blocks'; -- Perl5 Master Repository
