[perl #129916] Allow sub-in-stash outside of main

The sub-in-stash optimization introduced in 2eaf799 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

@@ -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;

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;
     }

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));
 		}

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,

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,

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) {

t/op/stash.t

@@ -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
 

t/op/sub.t

@@ -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::)';
 }
 

t/uni/caller.t

@@ -26,6 +26,9 @@ sub { @c = caller(0) } -> ();
 
 # Bug 20020517.003 (#9367), used to dump core
 sub ｆｏｏ { @c = caller(0) }
+# The subroutine only gets anonymised if it is relying on a real GV
+# for its name.
+() = *{"ｆｏｏ"}; # with quotes so that the op tree doesn’t reference the GV
 my $fooref = delete $ｍａｉｎ::{ｆｏｏ};
 $fooref -> ();
 ::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" );
@@ -55,6 +58,7 @@ sub { ｆ() } -> ();
 ::ok( $c[4], "hasargs true with anon sub" );
 
 sub ｆｏｏ2 { ｆ() }
+() = *{"ｆｏｏ2"}; # see ｆｏｏ notes above
 my $fooref2 = delete $ｍａｉｎ::{ｆｏｏ2};
 $fooref2 -> ();
 ::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" );

t/uni/stash.t

@@ -170,7 +170,7 @@ plan( tests => 49 );
             package ＦŌŌ３;
             sub 남えㄉ {};
             my $anon = sub {};
-            my $남えㄉ = eval q[\&남えㄉ];
+            my $남えㄉ = eval q[*남えㄉ{CODE}]; # not \&남えㄉ; need a real GV
             package main;
             delete $ＦŌŌ３::{남えㄉ}; # make named anonymous