In perl.git, the branch sprout/lexsub has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c60deeb444ee731a2c7ef908f7e1c29236889186?hp=c28fcee8c7fba883ec3e47f4247ea873e83f6946>
- Log ----------------------------------------------------------------- commit c60deeb444ee731a2c7ef908f7e1c29236889186 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 6 22:11:36 2012 -0700 pad.c: Put unavailability warning in one spot M pad.c commit ae34bcf1f650ed55b0c572f81f38e9b866371711 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 6 20:32:47 2012 -0700 Use the same outside logic for mysubs and formats By using find_runcv_where both for formats and my subs nested in inner clonable subs, we can simplify the code. It happens to make this work ($x is visible): use 5.01; sub not_lexical8 { my sub foo; foo(); sub not_lexical9 { my sub bar { my $x = 'khaki car keys for the khaki car'; not_lexical8(); sub foo { warn $x } } bar() } } not_lexical9(); This is definitely iffy code, but if making it work makes the imple- mentation simpler, so why not? M pad.c M t/cmd/lexsub.t commit bf605df330e210a7fa6df35978deecd5001b111e Author: Father Chrysostomos <[email protected]> Date: Thu Sep 6 18:05:35 2012 -0700 Fix subroutine unavailability during cloning sub foo { my $x; format = @ $x||'#' . } write; __END__ Variable "$x" is not available at - line 9. That oneâs OK. sub foo { my sub x {}; format = @ &x . } write; __END__ Variable "&x" is not available at - line 9. Assertion failed: (SvTYPE(_svmagic) >= SVt_PVMG), function S_mg_findext_flags, file mg.c, line 404. Abort trap That should say âSubroutineâ. And it shouldnât crash. The my-sub-cloning code was not taking this case into account. The value in the proto pad is an undef scalar. M pad.c M t/cmd/lexsub.t commit 5a05e28d433b4c47fa5b086b04df92931138efc4 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 6 16:03:20 2012 -0700 âSubroutine "&x" is not availableâ during compilation sub { my $x; sub { eval '$x' } }->()() __END__ Variable "$x" is not available at (eval 1) line 2. That oneâs OK (though I wonder about the line number). sub { my sub x {}; sub { eval '\&x' } }->()() __END__ Variable "&x" is not available at (eval 1) line 1. That should say âSubroutineâ. M pad.c M pod/perldiag.pod M t/cmd/lexsub.t M t/porting/diag.t commit c04d8f8637cc416ac23283d9628bc11b102c92a2 Author: Father Chrysostomos <[email protected]> Date: Tue Sep 4 10:24:57 2012 -0700 In cv_clone, use pad ID to identify mysub outside This code prints ARRAY(0x802e10), whereas it should print SCALAR(0xfedbee): undef &bar; eval 'sub bar { my @x }'; { my sub foo; foo(); sub bar { CORE::state $x; sub foo { warn \$x } } } The foo sub has a strong CvOUTSIDE pointer, but what it points to can still be undefined and redefined. So we need to identify it by its pad. M pad.c M t/cmd/lexsub.t ----------------------------------------------------------------------- Summary of changes: pad.c | 43 ++++++++++++++++++++++---------- pod/perldiag.pod | 30 +++++++++++++++++++++++ t/cmd/lexsub.t | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++++- t/porting/diag.t | 2 +- 4 files changed, 129 insertions(+), 16 deletions(-) diff --git a/pad.c b/pad.c index 216c828..912ca99 100644 --- a/pad.c +++ b/pad.c @@ -1122,6 +1122,17 @@ the parent pad. /* the CV does late binding of its lexicals */ #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM) +static void +S_unavailable(pTHX_ SV *namesv) +{ + /* diag_listed_as: Variable "%s" is not available */ + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "%se \"%"SVf"\" is not available", + *SvPVX_const(namesv) == '&' + ? "Subroutin" + : "Variabl", + namesv); +} STATIC PADOFFSET S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, @@ -1244,8 +1255,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, : *out_flags & PAD_FAKELEX_ANON) { if (warn) - Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%"SVf"\" is not available", + S_unavailable(aTHX_ newSVpvn_flags(namepv, namelen, SVs_TEMP | (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); @@ -1293,8 +1303,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, && (!CvDEPTH(cv) || !staleok) && !SvPAD_STATE(name_svp[offset])) { - Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%"SVf"\" is not available", + S_unavailable(aTHX_ newSVpvn_flags(namepv, namelen, SVs_TEMP | (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); @@ -1983,12 +1992,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) */ if (!outside) { - if (SvTYPE(proto) == SVt_PVCV) - { + if (CvWEAKOUTSIDE(proto)) outside = find_runcv(NULL); - if (!CvANON(proto) && CvROOT(outside) != CvROOT(CvOUTSIDE(proto))) - outside = CvOUTSIDE(proto); - } else { outside = CvOUTSIDE(proto); if ((CvCLONE(outside) && ! CvCLONED(outside)) @@ -2004,7 +2009,6 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) depth = outside ? CvDEPTH(outside) : 0; if (!depth) depth = 1; - assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside)); ENTER; SAVESPTR(PL_compcv); @@ -2025,7 +2029,6 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) outpad = outside && CvPADLIST(outside) ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth]) : NULL; - assert(outpad || SvTYPE(cv) == SVt_PVFM); if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id; for (ix = fpad; ix > 0; ix--) { @@ -2038,8 +2041,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) && (!outside || !CvDEPTH(outside))) ) { - Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%"SVf"\" is not available", namesv); + S_unavailable(aTHX_ namesv); sv = NULL; } else @@ -2063,6 +2065,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) { /* my sub */ + sv = newSV_type(SVt_PVCV); + if (SvTYPE(ppad[ix]) == SVt_PVCV) { /* This is actually a stub with a proto CV attached to it by magic. Since the stub itself is used when the proto is cloned, we need a new stub @@ -2074,10 +2078,21 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) assert(mg->mg_obj); assert(SvTYPE(ppad[ix]) == SVt_PVCV); assert(CvNAME_HEK((CV *)ppad[ix])); - sv = newSV_type(SVt_PVCV); CvNAME_HEK_set(sv, share_hek_hek(CvNAME_HEK((CV *)ppad[ix]))); sv_magic(sv,mg->mg_obj,PERL_MAGIC_proto,NULL,0); + } + else { + assert(SvTYPE(ppad[ix]) == SVt_NULL); + /* Unavailable; just provide a stub, but name it */ + CvNAME_HEK_set( + sv, + share_hek(SvPVX_const(namesv)+1, + SvCUR(namesv) - 1 + * (SvUTF8(namesv) ? -1 : 1), + 0) + ); + } } else sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 4e3d36a..507288e 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -4563,6 +4563,36 @@ was either never opened or has since been closed. stubs. Stubs should never be implicitly created, but explicit calls to C<can> may break this. +=item Subroutine "&%s" is not available + +(W closure) During compilation, an inner named subroutine or eval is +attempting to capture an outer lexical subroutine that is not currently +available. This can happen for one of two reasons. First, the lexical +subroutine may be declared in an outer anonymous subroutine that has not +yet been created. (Remember that named subs are created at compile time, +while anonymous subs are created at run-time.) For example, + + sub { my sub a {...} sub f { \&a } } + +At the time that f is created, it can't capture the current the "a" sub, +since the anonymous subroutine hasn't been created yet. Conversely, the +following won't give a warning since the anonymous subroutine has by now +been created and is live: + + sub { my sub a {...} eval 'sub f { \&a }' }->(); + +The second situation is caused by an eval accessing a variable that has +gone out of scope, for example, + + sub f { + my sub a {...} + sub { eval '\&a' } + } + f()->(); + +Here, when the '\&a' in the eval is being compiled, f() is not currently +being executed, so its &a is not available for capture. + =item "%s" subroutine &%s masks earlier declaration in same %s (W misc) A "my" or "state" subroutine has been redeclared in the diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t index 72ad6c7..f982a0e 100644 --- a/t/cmd/lexsub.t +++ b/t/cmd/lexsub.t @@ -8,7 +8,7 @@ BEGIN { *bar::like = *like; } no warnings 'deprecated'; -plan 112; +plan 118; # -------------------- our -------------------- # @@ -489,7 +489,61 @@ sub make_anon_with_my_sub{ eval "#line 56 pygpyf\nsub redef {}"; is $w, "Subroutine redef redefined at pygpyf line 56.\n", "sub redefinition warnings from my subs"; + + undef $w; + sub { + my sub x {}; + sub { eval "#line 87 khaki\n\\&x" } + }->()(); + is $w, "Subroutine \"&x\" is not available at khaki line 87.\n", + "unavailability warning during compilation of eval in closure"; + + undef $w; + no warnings 'void'; + eval <<'->()();'; +#line 87 khaki + sub { + my sub x{} + sub not_lexical8 { + \&x + } + } +->()(); + is $w, "Subroutine \"&x\" is not available at khaki line 90.\n", + "unavailability warning during compilation of named sub in anon"; + + undef $w; + sub not_lexical9 { + my sub x {}; + format = +@ +&x +. + } + eval { write }; + my($f,$l) = (__FILE__,__LINE__ - 1); + is $w, "Subroutine \"&x\" is not available at $f line $l.\n", + 'unavailability warning during cloning'; + $l -= 3; + is $@, "Undefined subroutine &x called at $f line $l.\n", + 'Vivified sub is correctly named'; +} +sub not_lexical10 { + my sub foo; + foo(); + sub not_lexical11 { + my sub bar { + my $x = 'khaki car keys for the khaki car'; + not_lexical10(); + sub foo { + is $x, 'khaki car keys for the khaki car', + 'mysubs in inner clonables use the running clone of their CvOUTSIDE' + } + } + bar() + } } +not_lexical11(); # -------------------- Interactions (and misc tests) -------------------- # @@ -544,3 +598,17 @@ undef *not_lexical6; sub not_lexical6 { sub foo { } } pass 'no crash when cloning a mysub declared inside an undef pack sub'; } + +undef ¬_lexical7; +eval 'sub not_lexical7 { my @x }'; +{ + my sub foo; + foo(); + sub not_lexical7 { + state $x; + sub foo { + is ref \$x, 'SCALAR', + "redeffing a mysub's outside does not make it use the wrong pad" + } + } +} diff --git a/t/porting/diag.t b/t/porting/diag.t index 31a1e29..4dcdf3b 100644 --- a/t/porting/diag.t +++ b/t/porting/diag.t @@ -230,7 +230,7 @@ sub check_file { $sub = $_; } next if $sub =~ m/^XS/; - if (m</\* diag_listed_as: (.*) \*/>) { + if (m</\*\s*diag_listed_as: (.*?)\s*\*/>) { $listed_as = $1; $listed_as_line = $.+1; } -- Perl5 Master Repository
