[Merge] [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 branch includes various commits to fix the issue and other prob-
lems that the fix uncovered.

cpan/NEXT/lib/NEXT.pm

@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use overload ();
 
-our $VERSION = '0.67';
+our $VERSION = '0.67_01';
 
 sub NEXT::ELSEWHERE::ancestors
 {
@@ -64,17 +64,19 @@ sub NEXT::ELSEWHERE::buildAUTOLOAD
                 last if shift @forebears eq $caller_class
             }
             no strict 'refs';
+            # Use *{"..."} when first accessing the CODE slot, to make sure
+            # any typeglob stub is upgraded to a full typeglob.
             @{$NEXT::NEXT{$key,$wanted_method}} =
                 map {
                     my $stash = \%{"${_}::"};
-                    ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE}))
+                    ($stash->{$caller_method} && (*{"${_}::$caller_method"}{CODE}))
                         ? *{$stash->{$caller_method}}{CODE}
                         : () } @forebears
                     unless $wanted_method eq 'AUTOLOAD';
             @{$NEXT::NEXT{$key,$wanted_method}} =
                 map {
                     my $stash = \%{"${_}::"};
-                    ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE}))
+                    ($stash->{AUTOLOAD} && (*{"${_}::AUTOLOAD"}{CODE}))
                         ? "${_}::AUTOLOAD"
                         : () } @forebears
                     unless @{$NEXT::NEXT{$key,$wanted_method}||[]};

cpan/NEXT/t/next.t

@@ -1,4 +1,4 @@
-BEGIN { print "1..26\n"; }
+BEGIN { print "1..27\n"; }
 
 use NEXT;
 
@@ -16,13 +16,13 @@ sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() )
 sub B::DESTROY  { $_[0]->NEXT::DESTROY() }
 
 package C;
-sub C::DESTROY  { print "ok 24\n"; $_[0]->NEXT::DESTROY() }
+sub C::DESTROY  { print "ok 25\n"; $_[0]->NEXT::DESTROY() }
 
 package D;
 @D::ISA = qw( B C E );
 sub D::method   { return ( 2, $_[0]->NEXT::method() ) }
 sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) }
-sub D::DESTROY  { print "ok 23\n"; $_[0]->NEXT::DESTROY() }
+sub D::DESTROY  { print "ok 24\n"; $_[0]->NEXT::DESTROY() }
 sub D::oops     { $_[0]->NEXT::method() }
 sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) }
 
@@ -31,12 +31,12 @@ package E;
 sub E::method   { return ( 4,  $_[0]->NEXT::method(), $_[0]->NEXT::method() ) }
 sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() ) 
 			if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
-sub E::DESTROY  { print "ok 25\n"; $_[0]->NEXT::DESTROY() }
+sub E::DESTROY  { print "ok 26\n"; $_[0]->NEXT::DESTROY() }
 
 package F;
 sub F::method   { return ( 5  ) }
 sub F::AUTOLOAD { return ( 11 ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
-sub F::DESTROY  { print "ok 26\n" }
+sub F::DESTROY  { print "ok 27\n" }
 
 package G;
 sub G::method   { return ( 6 ) }
@@ -104,4 +104,15 @@ eval {
 };
 print "ok 22\n";
 
-# CAN REDISPATCH DESTRUCTORS (ok 23..26)
+# TEST WITH CONSTANTS (23)
+
+package Hay;
+@ISA = 'Bee';
+sub foo { return shift->NEXT::foo }
+package Bee;
+use constant foo => 3;
+package main;
+print "not " unless Hay->foo eq '3';
+print "ok 23\n";
+
+# CAN REDISPATCH DESTRUCTORS (ok 24..27)

ext/B/B/Concise.pm

@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
 
 use Exporter (); # use #5
 
-our $VERSION   = "1.001";
+our $VERSION   = "1.002";
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
 		     concise_subref concise_cv concise_main
@@ -145,13 +145,14 @@ sub concise_subref {
 
 sub concise_stashref {
     my($order, $h) = @_;
-    local *s;
+    my $name = svref_2object($h)->NAME;
     foreach my $k (sort keys %$h) {
 	next unless defined $h->{$k};
-	*s = $h->{$k};
-	my $coderef = *s{CODE} or next;
+	my $coderef = ref $h->{$k} eq 'CODE' ? $h->{$k}
+		    : ref\$h->{$k} eq 'GLOB' ? *{$h->{$k}}{CODE} || next
+		    : next;
 	reset_sequence();
-	print "FUNC: ", *s, "\n";
+	print "FUNC: *", $name, "::", $k, "\n";
 	my $codeobj = svref_2object($coderef);
 	next unless ref $codeobj eq 'B::CV';
 	eval { concise_cv_obj($order, $codeobj, $k) };

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;

lib/B/Deparse.pm

@@ -50,7 +50,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         MDEREF_SHIFT
     );
 
-$VERSION = '1.42';
+$VERSION = '1.43';
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -512,6 +512,10 @@ sub todo {
     } else {
 	$seq = 0;
     }
+    my $stash = $cv->STASH;
+    if (class($stash) eq 'HV') {
+        $self->{packs}{$stash->NAME}++;
+    }
     push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name];
 }
 
@@ -809,6 +813,14 @@ sub print_protos {
     my $ar;
     my @ret;
     foreach $ar (@{$self->{'protos_todo'}}) {
+	if (ref $ar->[1]) {
+	    # Only print a constant if it occurs in the same package as a
+	    # dumped sub.  This is not perfect, but a heuristic that will
+	    # hopefully work most of the time.  Ideally we would use
+	    # CvFILE, but a constant stub has no CvFILE.
+	    my $pack = ($ar->[0] =~ /(.*)::/)[0];
+	    next if $pack and !$self->{packs}{$pack}
+	}
 	my $body = defined $ar->[1]
 		? ref $ar->[1]
 		    ? " () {\n    " . $self->const($ar->[1]->RV,0) . ";\n}"
@@ -850,6 +862,7 @@ sub new {
     $self->{'ex_const'} = "'???'";
     $self->{'expand'} = 0;
     $self->{'files'} = {};
+    $self->{'packs'} = {};
     $self->{'indent_size'} = 4;
     $self->{'linenums'} = 0;
     $self->{'parens'} = 0;

lib/B/Deparse.t

@@ -13,7 +13,7 @@ BEGIN {
 use warnings;
 use strict;
 
-my $tests = 46; # not counting those in the __DATA__ section
+my $tests = 49; # not counting those in the __DATA__ section
 
 use B::Deparse;
 my $deparse = B::Deparse->new();
@@ -152,6 +152,21 @@ $a =~ s/-e syntax OK\n//g;
 is($a, "use constant ('PI', 4);\n",
    "Proxy Constant Subroutines must not show up as (incorrect) prototypes");
 
+$a = `$^X $path "-MO=Deparse" -e "sub foo(){1}" 2>&1`;
+$a =~ s/-e syntax OK\n//g;
+is($a, "sub foo () {\n    1;\n}\n",
+   "Main prog consisting of just a constant (via empty proto)");
+
+$a = readpipe qq|$^X $path "-MO=Deparse"|
+             .qq| -e "package F; sub f(){0} sub s{}"|
+             .qq| -e "#line 123 four-five-six"|
+             .qq| -e "package G; sub g(){0} sub s{}" 2>&1|;
+$a =~ s/-e syntax OK\n//g;
+like($a, qr/sub F::f \(\) \{\s*0;\s*}/,
+   "Constant is dumped in package in which other subs are dumped");
+unlike($a, qr/sub g/,
+   "Constant is not dumped in package in which other subs are not dumped");
+
 #Re: perlbug #35857, patch #24505
 #handle warnings::register-ed packages properly.
 package B::Deparse::Wrapper;

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,
@@ -2997,7 +2997,7 @@ PP(pp_multideref)
                         }
                         else {
                             if (localizing) {
-                                if (HvNAME_get(hv) && isGV(sv))
+                                if (HvNAME_get(hv) && isGV_or_RVCV(sv))
                                     save_gp(MUTABLE_GV(sv),
                                         !(PL_op->op_flags & OPf_SPECIAL));
                                 else if (preeminent) {

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

sv.h

@@ -2146,6 +2146,10 @@ See also C<L</PL_sv_yes>> and C<L</PL_sv_no>>.
 	assert (!SvIOKp(sv));					       \
 	(SvFLAGS(sv) &= ~SVpgv_GP);				       \
     } STMT_END
+#ifdef PERL_CORE
+# define isGV_or_RVCV(kadawp) \
+    (isGV(kadawp) || (SvROK(kadawp) && SvTYPE(SvRV(kadawp)) == SVt_PVCV))
+#endif
 #define isREGEXP(sv) \
     (SvTYPE(sv) == SVt_REGEXP				      \
      || (SvFLAGS(sv) & (SVTYPEMASK|SVpgv_GP|SVf_FAKE))        \