[perl #101486] Make PL_curstash refcounted

This stops PL_curstash from pointing to a freed-and-reused scalar in
cases like ‘package Foo; BEGIN {*Foo:: = *Bar::}’.

In such cases, another BEGIN block, or any subroutine definition,
would cause a crash.  Now it just happily proceeds.  newATTRSUB and
newXS have been modified not to call mro_method_changed_in in such
cases, as it doesn’t make sense.

ext/Opcode/Opcode.pm

@@ -6,7 +6,7 @@ use strict;
 
 our($VERSION, @ISA, @EXPORT_OK);
 
-$VERSION = "1.20";
+$VERSION = "1.21";
 
 use Carp;
 use Exporter ();

ext/Opcode/Opcode.xs

@@ -294,8 +294,8 @@ PPCODE:
     /* the assignment to global defstash changes our sense of 'main'	*/
     PL_defstash = gv_stashsv(Package, GV_ADDWARN); /* should exist already	*/
 
-    save_hptr(&PL_curstash);
-    PL_curstash = PL_defstash;
+    SAVEGENERICSV(PL_curstash);
+    PL_curstash = (HV *)SvREFCNT_inc_simple(PL_defstash);
 
     /* defstash must itself contain a main:: so we'll add that now	*/
     /* take care with the ref counts (was cause of long standing bug)	*/

op.c

@@ -4508,10 +4508,10 @@ Perl_package(pTHX_ OP *o)
 
     PERL_ARGS_ASSERT_PACKAGE;
 
-    save_hptr(&PL_curstash);
+    SAVEGENERICSV(PL_curstash);
     save_item(PL_curstname);
 
-    PL_curstash = gv_stashsv(sv, GV_ADD);
+    PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
 
     sv_setsv(PL_curstname, sv);
 
@@ -6581,6 +6581,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	}
     }
     if (const_sv) {
+	HV *stash;
 	SvREFCNT_inc_simple_void_NN(const_sv);
 	if (cv) {
 	    assert(!CvROOT(cv) && !CvCONST(cv));
@@ -6594,13 +6595,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    GvCV_set(gv, NULL);
 	    cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
 	}
-        mro_method_changed_in( /* sub Foo::Bar () { 123 } */
+	stash =
             (CvGV(cv) && GvSTASH(CvGV(cv)))
                 ? GvSTASH(CvGV(cv))
                 : CvSTASH(cv)
                     ? CvSTASH(cv)
-                    : PL_curstash
-        );
+                    : PL_curstash;
+	if (HvENAME_HEK(stash))
+            mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
 	if (PL_madskills)
 	    goto install_block;
 	op_free(block);
@@ -6662,7 +6664,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 		}
 	    }
 	    GvCVGEN(gv) = 0;
-            mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
+	    if (HvENAME_HEK(GvSTASH(gv)))
+		/* sub Foo::bar { (shift)+1 } */
+		mro_method_changed_in(GvSTASH(gv));
 	}
     }
     if (!CvGV(cv)) {
@@ -6905,9 +6909,9 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv)
     PL_hints &= ~HINT_BLOCK_SCOPE;
 
     if (stash) {
-	SAVESPTR(PL_curstash);
+	SAVEGENERICSV(PL_curstash);
 	SAVECOPSTASH(PL_curcop);
-	PL_curstash = stash;
+	PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
 	CopSTASH_set(PL_curcop,stash);
     }
 
@@ -6986,7 +6990,8 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
             if (name) {
                 GvCV_set(gv,cv);
                 GvCVGEN(gv) = 0;
-                mro_method_changed_in(GvSTASH(gv)); /* newXS */
+                if (HvENAME_HEK(GvSTASH(gv)))
+                    mro_method_changed_in(GvSTASH(gv)); /* newXS */
             }
         }
         if (!name)

perl.c

@@ -1472,6 +1472,12 @@ Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
 =cut
 */
 
+#define SET_CURSTASH(newstash)                       \
+	if (PL_curstash != newstash) {                \
+	    SvREFCNT_dec(PL_curstash);                 \
+	    PL_curstash = (HV *)SvREFCNT_inc(newstash); \
+	}
+
 int
 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 {
@@ -1643,7 +1649,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 	while (PL_scopestack_ix > oldscope)
 	    LEAVE;
 	FREETMPS;
-	PL_curstash = PL_defstash;
+	SET_CURSTASH(PL_defstash);
 	if (PL_unitcheckav) {
 	    call_list(oldscope, PL_unitcheckav);
 	}
@@ -2227,7 +2233,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	}
     }
     CopLINE_set(PL_curcop, 0);
-    PL_curstash = PL_defstash;
+    SET_CURSTASH(PL_defstash);
     if (PL_e_script) {
 	SvREFCNT_dec(PL_e_script);
 	PL_e_script = NULL;
@@ -2298,7 +2304,7 @@ perl_run(pTHXx)
 	while (PL_scopestack_ix > oldscope)
 	    LEAVE;
 	FREETMPS;
-	PL_curstash = PL_defstash;
+	SET_CURSTASH(PL_defstash);
 	if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
 	    PL_endav && !PL_minus_c) {
 	    PERL_SET_PHASE(PERL_PHASE_END);
@@ -2688,7 +2694,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
 	    /* FALL THROUGH */
 	case 2:
 	    /* my_exit() was called */
-	    PL_curstash = PL_defstash;
+	    SET_CURSTASH(PL_defstash);
 	    FREETMPS;
 	    JMPENV_POP;
 	    my_exit_jump();
@@ -2795,7 +2801,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
 	/* FALL THROUGH */
     case 2:
 	/* my_exit() was called */
-	PL_curstash = PL_defstash;
+	SET_CURSTASH(PL_defstash);
 	FREETMPS;
 	JMPENV_POP;
 	my_exit_jump();
@@ -3544,7 +3550,7 @@ S_init_main_stash(pTHX)
     dVAR;
     GV *gv;
 
-    PL_curstash = PL_defstash = newHV();
+    PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
     /* We know that the string "main" will be in the global shared string
        table, so it's a small saving to use it rather than allocate another
        8 bytes.  */
@@ -3577,7 +3583,7 @@ S_init_main_stash(pTHX)
 #endif
     sv_grow(ERRSV, 240);	/* Preallocate - for immediate signals. */
     CLEAR_ERRSV();
-    PL_curstash = PL_defstash;
+    SET_CURSTASH(PL_defstash);
     CopSTASH_set(&PL_compiling, PL_defstash);
     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
@@ -3883,7 +3889,7 @@ Perl_init_debugger(pTHX)
     dVAR;
     HV * const ostash = PL_curstash;
 
-    PL_curstash = PL_debstash;
+    PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
 
     Perl_init_dbargs(aTHX);
     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
@@ -3898,6 +3904,7 @@ Perl_init_debugger(pTHX)
     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
     if (!SvIOK(PL_DBsignal))
 	sv_setiv(PL_DBsignal, 0);
+    SvREFCNT_dec(PL_curstash);
     PL_curstash = ostash;
 }
 
@@ -4772,7 +4779,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 	    while (PL_scopestack_ix > oldscope)
 		LEAVE;
 	    FREETMPS;
-	    PL_curstash = PL_defstash;
+	    SET_CURSTASH(PL_defstash);
 	    PL_curcop = &PL_compiling;
 	    CopLINE_set(PL_curcop, oldline);
 	    JMPENV_POP;

pp_ctl.c

@@ -3501,8 +3501,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     /* make sure we compile in the right package */
 
     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
-	SAVESPTR(PL_curstash);
-	PL_curstash = CopSTASH(PL_curcop);
+	SAVEGENERICSV(PL_curstash);
+	PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
     }
     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
     SAVESPTR(PL_beginav);

sv.c

@@ -13212,7 +13212,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* symbol tables */
     PL_defstash		= hv_dup_inc(proto_perl->Idefstash, param);
-    PL_curstash		= hv_dup(proto_perl->Icurstash, param);
+    PL_curstash		= hv_dup_inc(proto_perl->Icurstash, param);
     PL_debstash		= hv_dup(proto_perl->Idebstash, param);
     PL_globalstash	= hv_dup(proto_perl->Iglobalstash, param);
     PL_curstname	= sv_dup_inc(proto_perl->Icurstname, param);

t/op/stash.t

@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 56 );
+plan( tests => 57 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -327,3 +327,11 @@ fresh_perl_is(
 # [perl #88138] ' not equivalent to :: before a null
 ${"a'\0b"} = "c";
 is ${"a::\0b"}, "c", "' is equivalent to :: before a null";
+
+# [perl #101486] Clobbering the current package
+ok eval '
+     package Do;
+     BEGIN { *Do:: = *Re:: }
+     sub foo{};
+     1
+  ', 'no crashing or errors when clobbering the current package';

win32/perlhost.h

@@ -1757,6 +1757,10 @@ win32_start_child(LPVOID arg)
 		LEAVE;
 	    FREETMPS;
 	    PL_curstash = PL_defstash;
+	    if (PL_curstash != PL_defstash) {
+		SvREFCNT_dec(PL_curstash);
+		PL_curstash = (HV *)SvREFCNT_inc(PL_defstash);
+	    }
 	    if (PL_endav && !PL_minus_c)
 		call_list(oldscope, PL_endav);
 	    status = STATUS_EXIT;