[perl #7946] Lvalue subs do not autovivify

This commit makes autovivification work with lvalue subs. It follows
the same technique used by other autovivifiable ops (aelem, helem,
tc.), except that, due to flag constraints, it uses a single flag and
instead checks the op tree at run time to find out what sort of thing
to vivify.

The flag constraints are that these two flags:

#define OPpENTERSUB_HASTARG	32	/* Called from OP tree. */
#define OPpENTERSUB_NOMOD	64	/* Immune to op_lvalue() for :attrlist. */

conflict with these:

#define OPpDEREF		(32|64)	/* autovivify: Want ref to something: */
#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. */

Renumbering HASTARG and NOMOD is problematic, as there are places in
op.c that change entersubs into rv2cvs, and the entersub and rv2cv
flags would conflict. Setting the flags correctly when changing the
type is hard and would result in subtle bugs if not done perfectly.

Ops like ${...} don’t actually autovivify; it’s the op inside that
does it. In those cases, the parent op is flagged with OPpDEREFed, and
it skips get-magic, as it has already been called by the inner op.

Since entersub is now marked as being an autovivifying op, ${...} in
lvalue context ends up skipping get-magic if there is a foo() inside.
And this affects even regular subs. So pp_leavesub and pp_return have
to call get-magic; hence the new tests in gmagic.t.

diff --git a/cop.h b/cop.h
index 2f926c8..82eee29 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -635,7 +635,7 @@ struct block_format {
 #define PUSHSUB(cx)                                                    \
        PUSHSUB_BASE(cx)                                                \
        cx->blk_u16 = PL_op->op_private &                               \
-                             (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
+                     (OPpLVAL_INTRO|OPpENTERSUB_INARGS|OPpENTERSUB_DEREF);
 
 /* variant for use by OP_DBSTATE, where op_private holds hint bits */
 #define PUSHSUB_DB(cx)                                                 \

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index b27de10..25d908c 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -611,7 +611,7 @@ $priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv));
 @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
   for (qw(rv2gv rv2sv padsv aelem helem));
 $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
-@{$priv{"entersub"}}{4,16,32,64} = ("INARGS","DBG","TARG","NOMOD");
+@{$priv{"entersub"}}{1,4,16,32,64} = qw( DREF INARGS DBG TARG NOMOD );
 @{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()");
 $priv{"gv"}{32} = "EARLYCV";
 $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";

diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t
index e6735d9..189ec20 100644 (file)
--- a/ext/B/t/f_map.t
+++ b/ext/B/t/f_map.t
@@ -103,7 +103,7 @@ checkOptree(note   => q{},
 # b      <0> pushmark s
 # c      <#> gvsv[*_] s
 # d      <#> gv[*getkey] s/EARLYCV
-# e      <1> entersub[t5] lKS/TARG,1
+# e      <1> entersub[t5] lKS/TARG
 # f      <#> gvsv[*_] s
 # g      <@> list lK
 # h      <@> leave lKP
@@ -179,7 +179,7 @@ checkOptree(note   => q{},
 # k      <0> pushmark s
 # l      <#> gvsv[*_] s
 # m      <#> gv[*getkey] s/EARLYCV
-# n      <1> entersub[t10] sKS/TARG,1
+# n      <1> entersub[t10] sKS/TARG
 # o      <2> helem sKRM*/2
 # p      <2> sassign vKS/2
 # q      <0> unstack s

diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t
index 3cc0f26..3e0b7f8 100644 (file)
--- a/ext/B/t/optree_samples.t
+++ b/ext/B/t/optree_samples.t
@@ -477,7 +477,7 @@ checkOptree ( name  => '%h = map { getkey($_) => $_ } @a',
 # b      <0> pushmark s
 # c      <#> gvsv[*_] s
 # d      <#> gv[*getkey] s/EARLYCV
-# e      <1> entersub[t5] lKS/TARG,1
+# e      <1> entersub[t5] lKS/TARG
 # f      <#> gvsv[*_] s
 # g      <@> list lK
 # h      <@> leave lKP
@@ -501,7 +501,7 @@ EOT_EOT
 # b      <0> pushmark s
 # c      <$> gvsv(*_) s
 # d      <$> gv(*getkey) s/EARLYCV
-# e      <1> entersub[t2] lKS/TARG,1
+# e      <1> entersub[t2] lKS/TARG
 # f      <$> gvsv(*_) s
 # g      <@> list lK
 # h      <@> leave lKP
@@ -539,7 +539,7 @@ checkOptree ( name  => '%h=(); for $_(@a){$h{getkey($_)} = $_}',
 # i      <0> pushmark s
 # j      <#> gvsv[*_] s
 # k      <#> gv[*getkey] s/EARLYCV
-# l      <1> entersub[t10] sKS/TARG,1
+# l      <1> entersub[t10] sKS/TARG
 # m      <2> helem sKRM*/2
 # n      <2> sassign vKS/2
 # o      <0> unstack s
@@ -569,7 +569,7 @@ EOT_EOT
 # i      <0> pushmark s
 # j      <$> gvsv(*_) s
 # k      <$> gv(*getkey) s/EARLYCV
-# l      <1> entersub[t4] sKS/TARG,1
+# l      <1> entersub[t4] sKS/TARG
 # m      <2> helem sKRM*/2
 # n      <2> sassign vKS/2
 # o      <0> unstack s

diff --git a/op.c b/op.c
index 71452d6..cddf5b8 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1471,9 +1471,8 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type)
        if ((type == OP_UNDEF || type == OP_REFGEN) &&
            !(o->op_flags & OPf_STACKED)) {
            o->op_type = OP_RV2CV;              /* entersub => rv2cv */
-           /* The default is to set op_private to the number of children,
-              which for a UNOP such as RV2CV is always 1. And w're using
-              the bit for a flag in RV2CV, so we need it clear.  */
+           /* Both ENTERSUB and RV2CV use this bit, but for different pur-
+              poses, so we need it clear.  */
            o->op_private &= ~1;
            o->op_ppaddr = PL_ppaddr[OP_RV2CV];
            assert(cUNOPo->op_first->op_type == OP_NULL);
@@ -1894,6 +1893,11 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
            o->op_flags |= OPf_SPECIAL;
            o->op_private &= ~1;
        }
+       else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
+           o->op_private |= OPpENTERSUB_DEREF;
+           o->op_flags |= OPf_MOD;
+       }
+
        break;
 
     case OP_COND_EXPR:
@@ -9040,6 +9044,7 @@ Perl_ck_subr(pTHX_ OP *o)
     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
 
+    o->op_private &= ~1;
     o->op_private |= OPpENTERSUB_HASTARG;
     o->op_private |= (PL_hints & HINT_STRICT_REFS);
     if (PERLDB_SUB && PL_curstash != PL_debstash)
@@ -9783,14 +9788,20 @@ Perl_rpeep(pTHX_ register OP *o)
        case OP_RV2SV:
        case OP_RV2AV:
        case OP_RV2HV:
-           if (oldop
-                && (  oldop->op_type == OP_AELEM
+           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;
            }

diff --git a/op.h b/op.h
index 5466e57..74030d9 100644 (file)
--- a/op.h
+++ b/op.h
@@ -204,6 +204,7 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpENTERSUB_HASTARG    32      /* Called from OP tree. */
 #define OPpENTERSUB_NOMOD      64      /* Immune to op_lvalue() for :attrlist. */
 #define OPpENTERSUB_INARGS     4       /* Lval used as arg to a sub. */
+#define OPpENTERSUB_DEREF      1       /* Lval call that autovivifies. */
   /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER      8       /* Used & form to call. */
 #define OPpENTERSUB_NOPAREN    128     /* bare sub call (without parens) */

diff --git a/pp_ctl.c b/pp_ctl.c
index 0c51e28..043bef3 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2228,8 +2228,24 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
        }
        else
            *++newsp = &PL_sv_undef;
+       if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
+           SvGETMAGIC(TOPs);
+           if (!SvOK(TOPs)) {
+               U8 deref_type;
+               if (cx->blk_sub.retop->op_type == OP_RV2SV)
+                   deref_type = OPpDEREF_SV;
+               else if (cx->blk_sub.retop->op_type == OP_RV2AV)
+                   deref_type = OPpDEREF_AV;
+               else {
+                   assert(cx->blk_sub.retop->op_type == OP_RV2HV);
+                   deref_type = OPpDEREF_HV;
+               }
+               vivify_ref(TOPs, deref_type);
+           }
+       }
     }
     else if (gimme == G_ARRAY) {
+       assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF));
        while (++MARK <= SP) {
            *++newsp = *MARK;
            TAINT_NOT;          /* Each item is independent */
@@ -2245,6 +2261,7 @@ PP(pp_return)
     bool popsub2 = FALSE;
     bool clear_errsv = FALSE;
     bool lval = FALSE;
+    bool gmagic = FALSE;
     I32 gimme;
     SV **newsp;
     PMOP *newpm;
@@ -2287,6 +2304,7 @@ 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:
@@ -2332,11 +2350,15 @@ PP(pp_return)
                        FREETMPS;
                        *++newsp = sv_mortalcopy(sv);
                        SvREFCNT_dec(sv);
+                       if (gmagic) SvGETMAGIC(sv);
                    }
                }
+               else if (SvTEMP(*SP)) {
+                   *++newsp = *SP;
+                   if (gmagic) SvGETMAGIC(*SP);
+               }
                else
-                   *++newsp =
-                       SvTEMP(*SP) ? *SP : sv_mortalcopy(*SP);
+                   *++newsp = sv_mortalcopy(*SP);
            }
            else
                *++newsp = sv_mortalcopy(*SP);

diff --git a/pp_hot.c b/pp_hot.c
index ac915b4..7d0c6ec 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2595,12 +2595,14 @@ 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) {
@@ -2611,6 +2613,7 @@ PP(pp_leavesub)
                    *MARK = SvREFCNT_inc(TOPs);
                    FREETMPS;
                    sv_2mortal(*MARK);
+                   if (gmagic) SvGETMAGIC(*MARK);
                }
                else {
                    sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
@@ -2619,8 +2622,12 @@ PP(pp_leavesub)
                    SvREFCNT_dec(sv);
                }
            }
+           else if (SvTEMP(TOPs)) {
+               *MARK = TOPs;
+               if (gmagic) SvGETMAGIC(TOPs);
+           }
            else
-               *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+               *MARK = sv_mortalcopy(TOPs);
        }
        else {
            MEXTEND(MARK, 0);
@@ -2818,6 +2825,24 @@ PP(pp_leavesublv)
            SP = MARK;
        }
     }
+
+    if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
+       assert(gimme == G_SCALAR);
+       SvGETMAGIC(TOPs);
+       if (!SvOK(TOPs)) {
+           U8 deref_type;
+           if (cx->blk_sub.retop->op_type == OP_RV2SV)
+               deref_type = OPpDEREF_SV;
+           else if (cx->blk_sub.retop->op_type == OP_RV2AV)
+               deref_type = OPpDEREF_AV;
+           else {
+               assert(cx->blk_sub.retop->op_type == OP_RV2HV);
+               deref_type = OPpDEREF_HV;
+           }
+           vivify_ref(TOPs, deref_type);
+       }
+    }
+
   rvalue_array:
     PUTBACK;
 

diff --git a/t/op/gmagic.t b/t/op/gmagic.t
index 2979c08..6901609 100644 (file)
--- a/t/op/gmagic.t
+++ b/t/op/gmagic.t
@@ -69,6 +69,17 @@ my($rgot, $wgot) = $tyre->init(0);
 ok($rgot == 0, 'a plain *foo causes no get-magic');
 ok($wgot == 0, 'a plain *foo causes no set-magic');
 
+# get-magic when exiting a non-lvalue sub in potentially autovivify-
+# ing context
+$tied_to = tie $_{elem}, "Tie::Monitor";
+eval { () = sub { delete $_{elem} }->()->[3] };
+ok +($tied_to->init)[0],
+ 'get-magic is called on mortal magic var on sub exit in autoviv context';
+$tied_to = tie $_{elem}, "Tie::Monitor";
+eval { () = sub { return delete $_{elem} }->()->[3] };
+ok +($tied_to->init)[0],
+ 'get-magic is called on mortal magic var on return in autoviv context';
+
 done_testing();
 
 # adapted from Tie::Counter by Abigail

diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index f490ec4..0af4d91 100644 (file)
--- a/t/op/sub_lval.t
+++ b/t/op/sub_lval.t
@@ -3,7 +3,7 @@ BEGIN {
     @INC = '../lib';
     require './test.pl';
 }
-plan tests=>124;
+plan tests=>134;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -709,3 +709,23 @@ for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
     is $_, '44', '(lvalue)[0]'.$suffix;
 }
 continue { $suffix = ' (explicit return)' }
+
+# autovivification
+for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
+    undef $_;
+    &$sub()->[3] = 4;
+    is $_->[3], 4, 'func->[...] autovivification'.$suffix;
+    undef $_;
+    &$sub()->{3} = 4;
+    is $_->{3}, 4, 'func->{...} autovivification'.$suffix;
+    undef $_;
+    ${&$sub()} = 4;
+    is $$_, 4, '${func()} autovivification'      .$suffix;
+    undef $_;
+    @{&$sub()} = 4;
+    is "@$_", 4, '@{func()} autovivification'    .$suffix;
+    undef $_;
+    %{&$sub()} = (4,5);
+    is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix;
+}
+continue { $suffix = ' (explicit return)' }