[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.

diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index deec0bf..b9d9bbc 100644 (file)
--- a/ext/Opcode/Opcode.pm
+++ b/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 ();

diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs
index 587c299..4e6af8d 100644 (file)
--- a/ext/Opcode/Opcode.xs
+++ b/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)  */

diff --git a/op.c b/op.c
index e4e42b4..7690e4c 100644 (file)
--- a/op.c
+++ b/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)

diff --git a/perl.c b/perl.c
index 8f5f7c0..bbfae80 100644 (file)
--- a/perl.c
+++ b/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;

diff --git a/pp_ctl.c b/pp_ctl.c
index d15f99b..71e2ff8 100644 (file)
--- a/pp_ctl.c
+++ b/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);

diff --git a/sv.c b/sv.c
index 3efbc39..2e0553a 100644 (file)
--- a/sv.c
+++ b/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);

diff --git a/t/op/stash.t b/t/op/stash.t
index d755f74..e7d6609 100644 (file)
--- a/t/op/stash.t
+++ b/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';

diff --git a/win32/perlhost.h b/win32/perlhost.h
index 02ecf10..e8f5fb4 100644 (file)
--- a/win32/perlhost.h
+++ b/win32/perlhost.h
@@ -1757,6 +1757,10 @@ restart:
                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;