[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 232ab01..c99532a 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 e7041b1..2ed8f60 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 d5288a5..58a8cf2 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 12ed55b..605429e 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 01211e6..395b46b 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 6a6e3f2..e0fdc81 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 a5691ee..2894e3b 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 fc54f99..dc1b055 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 2f159e5..dd0b04d 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 73f52c8..7784a7a 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)