[perl #97088] Prevent double get-magic in various cases

This patch prevents get-magic from executing twice during autovivifi-
cation when the op doing the autovivification is not directly nested
inside the dereferencing op.

This can happen in cases like this:

    ${ (), $a } = 1;

Previously (as of 5.13.something), the outer op was marked with the
OPpDEREFed flag, which indicated that get-magic had already been
called by the vivifying op (calling get-magic during vivification is
inevitable):

$ perl5.14.0 -MO=Concise -e '${ $a } = 1'
8  <@> leave[1 ref] vKP/REFC ->(end)
1     <0> enter ->2
2     <;> nextstate(main 2 -e:1) v:{ ->3
7     <2> sassign vKS/2 ->8
3        <$> const[IV 1] s ->4
6        <1> rv2sv sKRM*/DREFed,1 ->7          <-- right here
-           <@> scope sK ->6
-              <0> ex-nextstate v ->4
5              <1> rv2sv sKM/DREFSV,1 ->6
4                 <#> gv[*a] s ->5
-e syntax OK

But in the ${()...} example above, there is a list op in the way that
prevents the flag from being set inside the peephole optimizer.  It’s
not even possible to set it correctly in all cases, as in this exam-
ple, which would need it both set and not set depending on which
branch of the ternary operator is executed:

    ${ $x ? delete $a[0] : $a[0] } = 1

Instead of setting the OPpDEREFed flag, we now make a non-magic copy
of the SV in vivify_ref (the first time get-magic is executed).

diff --git a/dump.c b/dump.c
index 232ab0167dc958dbedd721105b2a81cddea74f16..c99532ab58de4a2ac8bf312699e29c68a77440e1 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1020,10 +1020,6 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
                    sv_catpv(tmpsv, ",MAYBE_LVSUB");
            }
 
-           if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
-                   && (o->op_private & OPpDEREFed))
-               sv_catpv(tmpsv, ",DEREFed");
-
            if (optype == OP_AELEM || optype == OP_HELEM) {
                if (o->op_private & OPpLVAL_DEFER)
                    sv_catpv(tmpsv, ",LVAL_DEFER");

diff --git a/embed.fnc b/embed.fnc
index e7041b10428b6ab0cdf8807774422e66a24a4ced..2ed8f60ca1fce830e794cfa3a94740274f7a2593 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1384,7 +1384,7 @@ ApdR      |char*  |sv_uni_display |NN SV *dsv|NN SV *ssv|STRLEN pvlim|UV flags
 : Used by Data::Alias
 EXp    |void   |vivify_defelem |NN SV* sv
 : Used in pp.c
-p      |void   |vivify_ref     |NN SV* sv|U32 to_what
+pR     |SV*    |vivify_ref     |NN SV* sv|U32 to_what
 : Used in pp_sys.c
 p      |I32    |wait4pid       |Pid_t pid|NN int* statusp|int flags
 : Used in locale.c and perl.c

diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t
index d5288a519acb82ddfa79bb11f5c10df56c2d5137..58a8cf2eed2224d8f43482d40e56cc6f4c0d0fd4 100644 (file)
--- a/ext/B/t/f_sort.t
+++ b/ext/B/t/f_sort.t
@@ -517,7 +517,7 @@ checkOptree(name   => q{Compound sort/map Expression },
 # l  <|> mapwhile(other->m)[t26] lK
 # m      <#> gv[*_] s
 # n      <1> rv2sv sKM/DREFAV,1
-# o      <1> rv2av[t4] sKR/DREFed,1
+# o      <1> rv2av[t4] sKR/1
 # p      <$> const[IV 0] s
 # q      <2> aelem sK/2
 # -      <@> scope lK
@@ -552,7 +552,7 @@ EOT_EOT
 # l  <|> mapwhile(other->m)[t12] lK
 # m      <$> gv(*_) s
 # n      <1> rv2sv sKM/DREFAV,1
-# o      <1> rv2av[t2] sKR/DREFed,1
+# o      <1> rv2av[t2] sKR/1
 # p      <$> const(IV 0) s
 # q      <2> aelem sK/2
 # -      <@> scope lK

diff --git a/lib/overload.t b/lib/overload.t
index 12ed55be7ca22583c5d40ea85fbf652a97305b62..605429ede9fd1a99ac92f610458e5487c1c502e5 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -1820,7 +1820,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
        $subs{'%{}'} = '%s';
        push @tests, [ {qw(a 1 b 2 c 3)}, 'join "", sort keys %%{%s}',
-                       '(%{})', undef, [ 1, 2, 0 ], 0 ];
+                       '(%{})', undef, [ 1, 1, 0 ], 0 ];
 
        $subs{'&{}'} = '%s';
        push @tests, [ sub {99}, 'do {&{%s} for 1,2}',

diff --git a/op.c b/op.c
index 01211e6fcf6b0b26f2d7dd90b14ec19427a5804c..395b46b2834c562485915a52c1d53570413f5ff2 100644 (file)
--- a/op.c
+++ b/op.c
@@ -9972,27 +9972,6 @@ Perl_rpeep(pTHX_ register OP *o)
            DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
            break;
 
-       case OP_RV2SV:
-       case OP_RV2AV:
-       case OP_RV2HV:
-           if (oldop &&
-               (
-                (
-                   (  oldop->op_type == OP_AELEM
-                   || oldop->op_type == OP_PADSV
-                   || oldop->op_type == OP_RV2SV
-                   || oldop->op_type == OP_RV2GV
-                   || oldop->op_type == OP_HELEM
-                   )
-                && (oldop->op_private & OPpDEREF)
-                )
-                || (   oldop->op_type == OP_ENTERSUB
-                    && oldop->op_private & OPpENTERSUB_DEREF )
-               )
-           ) {
-               o->op_private |= OPpDEREFed;
-           }
-
        case OP_SORT: {
            /* will point to RV2AV or PADAV op on LHS/RHS of assign */
            OP *oleft;

diff --git a/op.h b/op.h
index 6a6e3f2d1001e3f8cee686a90e66d022b0a7523b..e0fdc81778fe9dbf21c7153aa04897979cd40feb 100644 (file)
--- a/op.h
+++ b/op.h
@@ -201,8 +201,6 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpDEREF_AV            32      /*   Want ref to AV. */
 #define OPpDEREF_HV            64      /*   Want ref to HV. */
 #define OPpDEREF_SV            (32|64) /*   Want ref to SV. */
-/* Private for OP_RV2SV, OP_RV2AV, OP_RV2AV */
-#define OPpDEREFed             4       /* prev op was OPpDEREF */
 
   /* OP_ENTERSUB only */
 #define OPpENTERSUB_DB         16      /* Debug subroutine. */

diff --git a/pp.c b/pp.c
index a5691ee73644622fd62d77fa0190cb388532ce0a..2894e3b3787a305889677a4c9652949c10347a6a 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -314,8 +314,7 @@ PP(pp_rv2sv)
     dVAR; dSP; dTOPss;
     GV *gv = NULL;
 
-    if (!(PL_op->op_private & OPpDEREFed))
-       SvGETMAGIC(sv);
+    SvGETMAGIC(sv);
     if (SvROK(sv)) {
        if (SvAMAGIC(sv)) {
            sv = amagic_deref_call(sv, to_sv_amg);
@@ -353,7 +352,7 @@ PP(pp_rv2sv)
                Perl_croak(aTHX_ "%s", PL_no_localize_ref);
        }
        else if (PL_op->op_private & OPpDEREF)
-           vivify_ref(sv, PL_op->op_private & OPpDEREF);
+           sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
     }
     SETs(sv);
     RETURN;

diff --git a/pp_ctl.c b/pp_ctl.c
index fc54f9939115b9f23f5823b1bd02c0f673aa2f91..dc1b0556816bb16d3ab39ae74ae4e68a2183f11a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2373,7 +2373,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
                    assert(cx->blk_sub.retop->op_type == OP_RV2HV);
                    deref_type = OPpDEREF_HV;
                }
-               vivify_ref(TOPs, deref_type);
+               TOPs = vivify_ref(TOPs, deref_type);
            }
        }
     }
@@ -2423,7 +2423,6 @@ PP(pp_return)
     bool popsub2 = FALSE;
     bool clear_errsv = FALSE;
     bool lval = FALSE;
-    bool gmagic = FALSE;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -2466,7 +2465,6 @@ PP(pp_return)
        popsub2 = TRUE;
        lval = !!CvLVALUE(cx->blk_sub.cv);
        retop = cx->blk_sub.retop;
-       gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
        cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
        break;
     case CXt_EVAL:
@@ -2506,7 +2504,6 @@ PP(pp_return)
                        *++newsp = SvREFCNT_inc(*SP);
                        FREETMPS;
                        sv_2mortal(*newsp);
-                       if (gmagic) SvGETMAGIC(*newsp);
                    }
                    else {
                        sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
@@ -2517,7 +2514,6 @@ PP(pp_return)
                }
                else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
                    *++newsp = *SP;
-                   if (gmagic) SvGETMAGIC(*SP);
                }
                else
                    *++newsp = sv_mortalcopy(*SP);

diff --git a/pp_hot.c b/pp_hot.c
index 2f159e5fd5c97dc766aee87780cf103c27850a21..dd0b04d6cd522bc40def0122ce9791aee283c13f 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -311,7 +311,7 @@ PP(pp_padsv)
                SAVECLEARSV(PAD_SVl(PL_op->op_targ));
         if (PL_op->op_private & OPpDEREF) {
            PUTBACK;
-           vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
+           TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
            SPAGAIN;
        }
     }
@@ -759,8 +759,7 @@ PP(pp_rv2av)
     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 
-    if (!(PL_op->op_private & OPpDEREFed))
-       SvGETMAGIC(sv);
+    SvGETMAGIC(sv);
     if (SvROK(sv)) {
        if (SvAMAGIC(sv)) {
            sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
@@ -1792,8 +1791,10 @@ PP(pp_helem)
            else
                SAVEHDELETE(hv, keysv);
        }
-       else if (PL_op->op_private & OPpDEREF)
-           vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+       else if (PL_op->op_private & OPpDEREF) {
+           PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
+           RETURN;
+       }
     }
     sv = (svp ? *svp : &PL_sv_undef);
     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
@@ -2463,14 +2464,12 @@ PP(pp_leavesub)
     I32 gimme;
     register PERL_CONTEXT *cx;
     SV *sv;
-    bool gmagic;
 
     if (CxMULTICALL(&cxstack[cxstack_ix]))
        return 0;
 
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* temporarily protect top context */
-    gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
 
     TAINT_NOT;
     if (gimme == G_SCALAR) {
@@ -2481,7 +2480,6 @@ PP(pp_leavesub)
                    *MARK = SvREFCNT_inc(TOPs);
                    FREETMPS;
                    sv_2mortal(*MARK);
-                   if (gmagic) SvGETMAGIC(*MARK);
                }
                else {
                    sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
@@ -2492,7 +2490,6 @@ PP(pp_leavesub)
            }
            else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
                *MARK = TOPs;
-               if (gmagic) SvGETMAGIC(TOPs);
            }
            else
                *MARK = sv_mortalcopy(TOPs);
@@ -2842,8 +2839,10 @@ PP(pp_aelem)
            else
                SAVEADELETE(av, elem);
        }
-       else if (PL_op->op_private & OPpDEREF)
-           vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+       else if (PL_op->op_private & OPpDEREF) {
+           PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
+           RETURN;
+       }
     }
     sv = (svp ? *svp : &PL_sv_undef);
     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
@@ -2852,7 +2851,7 @@ PP(pp_aelem)
     RETURN;
 }
 
-void
+SV*
 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 {
     PERL_ARGS_ASSERT_VIVIFY_REF;
@@ -2876,6 +2875,14 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
        SvROK_on(sv);
        SvSETMAGIC(sv);
     }
+    if (SvGMAGICAL(sv)) {
+       /* copy the sv without magic to prevent magic from being
+          executed twice */
+       SV* msv = sv_newmortal();
+       sv_setsv_nomg(msv, sv);
+       return msv;
+    }
+    return sv;
 }
 
 PP(pp_method)

diff --git a/proto.h b/proto.h
index 73f52c8680ae300263ff35ec98c13043ee419d31..7784a7a30e4327e30bd32ba260f86d6a449ec047 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4424,7 +4424,8 @@ PERL_CALLCONV void        Perl_vivify_defelem(pTHX_ SV* sv)
 #define PERL_ARGS_ASSERT_VIVIFY_DEFELEM        \
        assert(sv)
 
-PERL_CALLCONV void     Perl_vivify_ref(pTHX_ SV* sv, U32 to_what)
+PERL_CALLCONV SV*      Perl_vivify_ref(pTHX_ SV* sv, U32 to_what)
+                       __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_VIVIFY_REF    \
        assert(sv)