[perl #129916] Allow sub-in-stash outside of main
authorFather Chrysostomos <sprout@cpan.org>
Thu, 21 Sep 2017 14:06:05 +0000 (07:06 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 8 Oct 2017 20:06:06 +0000 (13:06 -0700)
The sub-in-stash optimization introduced in 2eaf799e only applied to
subs in the main stash, not in other stashes, due to a problem with
the logic in newATTRSUB.

This comment:

   Also, we may be called from load_module at run time, so
   PL_curstash (which sets CvSTASH) may not point to the stash the
   sub is stored in.

explains why we need the PL_curstash != CopSTASH(PL_curcop) check.
(Perl_load_module will fail without it.) But that logic does not work
properly at compile time (when PL_curcop == &PL_compiling).

The value of CopSTASH(&PL_compiling) is never actually used.  It is
always set to the main stash.  So if we check that PL_curstash !=
CopSTASH(PL_curcop) and forego the optimization in that case, we will
never optimize subs outside of the main stash.

What we really need is to check IN_PERL_RUNTIME && PL_curstash !=
opSTASH(PL_curcop).  I.e., forego the optimization at run time if the
stashes differ.  That is what this commit implements.

One observable side effect of this change is that deleting a stash
element no longer anonymizes the CV if the CV had no GV that it was
depending on to provide its name.  Since the main thing in such situa-
tions is that we do not get a crash, I think this change (arguably an
improvement) is acceptable.)

-----------

A bit of explanation of various other changes:

gv.c:require_tie_mod needed a bit of help, since it could not handle
sub refs in stashes.

To keep localisation of stash elements working the same way,
local($Stash::{foo}) now upgrades a coderef to a full GV before the
localisation.  (Changes in two pp*.c files and in scope.c:save_gp.)

t/op/stash.t contains a test that makes sure that perl does not crash
when a GV with a CV pointing to it gets deleted.  This commit tweaks
the test so that it continues to test that.  (There has to be a GV for
the test to test what it is meant to test.)

Similarly with t/uni/caller.t and t/uni/stash.t.

op.c:rv2cv_op_cv with the _MAYBE_NAME_GV flag was returning the cal-
ling GV in those cases where a GV-less sub is called via a GV.  E.g.,
*main = \&Foo::foo; main().  This meant that errors like ‘Not enough
arguments’ were giving the wrong sub name.

newATTRSUB was not calling mro_method_changed_in when storing a
sub as an RV.

gv_init needs to arrange for the new GV to have the file and line num-
ber corresponding to the sub in it.  These are taken from CvSTART,
which may be off by a few lines, but is the closest we have to the
place the sub was declared.

gv.c
op.c
pad.c
pp.c
pp_hot.c
scope.c
t/op/stash.t
t/op/sub.t
t/uni/caller.t
t/uni/stash.t

diff --git a/gv.c b/gv.c
index eebf542..5d96332 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -373,6 +373,9 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
+    const bool really_sub =
+       has_constant && SvTYPE(has_constant) == SVt_PVCV;
+    COP * const old = PL_curcop;
 
     PERL_ARGS_ASSERT_GV_INIT_PVN;
     assert (!(proto && has_constant));
@@ -411,14 +414,19 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     SvIOK_off(gv);
     isGV_with_GP_on(gv);
 
+    if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
+     && (  CvSTART(has_constant)->op_type == OP_NEXTSTATE
+       || CvSTART(has_constant)->op_type == OP_DBSTATE))
+       PL_curcop = (COP *)CvSTART(has_constant);
     GvGP_set(gv, Perl_newGP(aTHX_ gv));
+    PL_curcop = old;
     GvSTASH(gv) = stash;
     if (stash)
        Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
     gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
     if (flags & GV_ADDMULTI || doproto)        /* doproto means it */
        GvMULTI_on(gv);                 /* _was_ mentioned */
-    if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
+    if (really_sub) {
        /* Not actually a constant.  Just a regular sub.  */
        CV * const cv = (CV *)has_constant;
        GvCV_set(gv,cv);
@@ -1342,11 +1350,16 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
       PUSHSTACKi(PERLSI_MAGIC);
       ENTER;
 
-#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0)
+#define GET_HV_FETCH_TIE_FUNC                           \
+    (  (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0))     \
+    && *gvp                                               \
+    && (  (isGV(*gvp) && GvCV(*gvp))                       \
+       || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV)  ) \
+    )
 
       /* Load the module if it is not loaded.  */
       if (!(stash = gv_stashpvn(name, len, 0))
-       || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+       || ! GET_HV_FETCH_TIE_FUNC)
       {
        SV * const module = newSVpvn(name, len);
        const char type = varname == '[' ? '$' : '%';
@@ -1358,12 +1371,12 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
        if (!stash)
            Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
                    type, varname, name);
-       else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+       else if (! GET_HV_FETCH_TIE_FUNC)
            Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
                    type, varname, name);
       }
       /* Now call the tie function.  It should be in *gvp.  */
-      assert(gvp); assert(*gvp); assert(GvCV(*gvp));
+      assert(gvp); assert(*gvp);
       PUSHMARK(SP);
       XPUSHs((SV *)gv);
       PUTBACK;
diff --git a/op.c b/op.c
index 06ec00b..c3e9f80 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3769,6 +3769,13 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
 
+            if (curstash && svname == (SV *)name
+             && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
+                svname = sv_2mortal(newSVsv(PL_curstname));
+                sv_catpvs(svname, "::");
+                sv_catsv(svname, (SV *)name);
+            }
+
             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
                 " in %" SVf,
@@ -8583,7 +8590,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
           sub is stored in.  */
        const I32 flags =
           ec ? GV_NOADD_NOINIT
-             :   PL_curstash != CopSTASH(PL_curcop)
+             :   IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop)
               || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
                    ? gv_fetch_flags
                    : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
@@ -8900,6 +8907,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                SvROK_on(gv);
            }
            SvRV_set(gv, (SV *)cv);
+           if (HvENAME_HEK(PL_curstash))
+               mro_method_changed_in(PL_curstash);
        }
     }
 
@@ -11598,11 +11607,18 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
     }
     if (SvTYPE((SV*)cv) != SVt_PVCV)
        return NULL;
-    if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
-       if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
-        && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
+    if (flags & RV2CVOPCV_RETURN_NAME_GV) {
+       if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
            gv = CvGV(cv);
        return (CV*)gv;
+    }
+    else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
+       if (CvLEXICAL(cv) || CvNAMED(cv))
+           return NULL;
+       if (!CvANON(cv) || !gv)
+           gv = CvGV(cv);
+       return (CV*)gv;
+
     } else {
        return cv;
     }
diff --git a/pad.c b/pad.c
index bbc835a..9c20d66 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -2295,7 +2295,10 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
                if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
                    sv_sethek(retsv, CvNAME_HEK(cv));
                else {
-                   sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
+                   if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
+                       sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
+                   else
+                       sv_setpvs(retsv, "__ANON__");
                    sv_catpvs(retsv, "::");
                    sv_cathek(retsv, CvNAME_HEK(cv));
                }
diff --git a/pp.c b/pp.c
index 46366c3..822b694 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -5045,7 +5045,7 @@ PP(pp_hslice)
                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
             }
             if (localizing) {
-               if (HvNAME_get(hv) && isGV(*svp))
+               if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
                    save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
                else if (preeminent)
                    save_helem_flags(hv, keysv, svp,
index 40b8507..f356d09 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2561,7 +2561,7 @@ PP(pp_helem)
            RETURN;
        }
        if (localizing) {
-           if (HvNAME_get(hv) && isGV(*svp))
+           if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
                save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
            else if (preeminent)
                save_helem_flags(hv, keysv, svp,
diff --git a/scope.c b/scope.c
index dfaab80..7da26a4 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -330,6 +330,17 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
 {
     PERL_ARGS_ASSERT_SAVE_GP;
 
+    /* XXX For now, we just upgrade any coderef in the stash to a full GV
+           during localisation.  Maybe at some point we could make localis-
+           ation work without needing the upgrade.  (In which case our
+           callers should probably call a different function, not save_gp.)
+     */
+    if (!isGV(gv)) {
+        assert(isGV_or_RVCV(gv));
+        (void)CvGV(SvRV((SV *)gv)); /* CvGV does the upgrade */
+        assert(isGV(gv));
+    }
+
     save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
 
     if (empty) {
index c9634a3..a507c42 100644 (file)
@@ -179,7 +179,7 @@ SKIP: {
        package FOO3;
        sub named {};
        my $anon = sub {};
-       my $named = eval q[\&named];
+       my $named = eval q[*named{CODE}]; # not \&named; we want a real GV
        package main;
        delete $FOO3::{named}; # make named anonymous
 
index 5c501b1..f73abb4 100644 (file)
@@ -423,7 +423,6 @@ is ref($main::{rt_129916}), 'CODE', 'simple sub stored as CV in stash (main::)';
     sub foo { 42 }
 }
 {
-    local $TODO = "CV symbol table optimization only works in main:: [perl #129916]";
     is ref($RT129916::{foo}), 'CODE', 'simple sub stored as CV in stash (non-main::)';
 }
 
index de314b0..c48018c 100644 (file)
@@ -26,6 +26,9 @@ sub { @c = caller(0) } -> ();
 
 # Bug 20020517.003 (#9367), used to dump core
 sub foo { @c = caller(0) }
+# The subroutine only gets anonymised if it is relying on a real GV
+# for its name.
+() = *{"foo"}; # with quotes so that the op tree doesn’t reference the GV
 my $fooref = delete $main::{foo};
 $fooref -> ();
 ::is( $c[3], "main::__ANON__", "deleted subroutine name" );
@@ -55,6 +58,7 @@ sub { f() } -> ();
 ::ok( $c[4], "hasargs true with anon sub" );
 
 sub foo2 { f() }
+() = *{"foo2"}; # see foo notes above
 my $fooref2 = delete $main::{foo2};
 $fooref2 -> ();
 ::is( $c[3], "main::__ANON__", "deleted subroutine name" );
index 31d6c9d..e329faa 100644 (file)
@@ -170,7 +170,7 @@ plan( tests => 49 );
             package FŌŌ3;
             sub 남えㄉ {};
             my $anon = sub {};
-            my $남えㄉ = eval q[\&남えㄉ];
+            my $남えㄉ = eval q[*남えㄉ{CODE}]; # not \&남えㄉ; need a real GV
             package main;
             delete $FŌŌ3::{남えㄉ}; # make named anonymous