[perl #119797] Fix if/else in lvalue sub

When if/else/unless is the last thing in an lvalue sub, the lvalue
context is not always propagated properly and scope exit tries to
copy things, including arrays, resulting in ‘Bizarre copy of ARRAY’.

This commit fixes the bizarre copy by flagging any leave op that is
part of an lvalue sub’s return sequence, using the OPpLEAVE flag added
for this purpose in the previous commit.  Then pp_leave uses that flag
to avoid copying return values, but protects them via the mortals
stack just like pp_leavesublv (actually pp_ctl.c:S_return_lvalues).

For ‘if’ and ‘unless’ without ‘else’, the lvalue context was not being
propagated, resulting in arrays’ getting flattened despite the lvalue
context.  op_lvalue_flags in op.c needed to handle AND and OR ops,
which ‘if’ and ‘unless’ compile to, to make this work.

diff --git a/embed.fnc b/embed.fnc
index ccb637bb123efb8f49a25434347ac4ac321e5e8d..3d00f37f7de53f8e5828e11ba2ffff9c97778ed3 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1955,7 +1955,8 @@ sR        |PerlIO *|check_type_and_open|NN SV *name
 #ifndef PERL_DISABLE_PMC
 sR     |PerlIO *|doopen_pm     |NN SV *name
 #endif
-s      |SV **  |adjust_stack_on_leave|NN SV **newsp|NN SV **sp|NN SV **mark|I32 gimme|U32 flags
+s      |SV **  |adjust_stack_on_leave|NN SV **newsp|NN SV **sp|NN SV **mark|I32 gimme \
+                                     |U32 flags|bool lvalue
 iRn    |bool   |path_is_searchable|NN const char *name
 sR     |I32    |run_user_filter|int idx|NN SV *buf_sv|int maxlen
 sR     |PMOP*  |make_matcher   |NN REGEXP* re

diff --git a/embed.h b/embed.h
index 00058f1e30ef4d33485e29e65bfc4c1a1bf6dac3..e0123067e14b585e58fc72fecdff2ccfaf6fac4a 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1516,7 +1516,7 @@
 #define refto(a)               S_refto(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_PP_CTL_C)
-#define adjust_stack_on_leave(a,b,c,d,e)       S_adjust_stack_on_leave(aTHX_ a,b,c,d,e)
+#define adjust_stack_on_leave(a,b,c,d,e,f)     S_adjust_stack_on_leave(aTHX_ a,b,c,d,e,f)
 #define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
 #define destroy_matcher(a)     S_destroy_matcher(aTHX_ a)
 #define do_smartmatch(a,b,c)   S_do_smartmatch(aTHX_ a,b,c)

diff --git a/op.c b/op.c
index c37f47b3db0512f253eb91acc673ca30c4b07d70..942b4d67d52850093a10c7c7f7c60a512e4804db 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2252,8 +2252,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
        PL_modcount++;
        break;
 
-    case OP_SCOPE:
     case OP_LEAVE:
+       o->op_private |= OPpLVALUE;
+    case OP_SCOPE:
     case OP_ENTER:
     case OP_LINESEQ:
        localize = 0;
@@ -2288,6 +2289,14 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
 
     case OP_COREARGS:
        return o;
+
+    case OP_AND:
+    case OP_OR:
+       if (type == OP_LEAVESUBLV) {
+           op_lvalue(cLOGOPo->op_first,             type);
+           op_lvalue(cLOGOPo->op_first->op_sibling, type);
+       }
+       goto nomod;
     }
 
     /* [20011101.069] File test operators interpret OPf_REF to mean that

diff --git a/pp_ctl.c b/pp_ctl.c
index ded6c9038f3222c5e356446ca1ae21ac237b32e3..4be2b194f9c98e90840f58b963ce3f62ed6f034b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2033,8 +2033,13 @@ PP(pp_dbstate)
        return NORMAL;
 }
 
+/* SVs on the stack that have any of the flags passed in are left as is.
+   Other SVs are protected via the mortals stack if lvalue is true, and
+   copied otherwise. */
+
 STATIC SV **
-S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
+S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
+                             U32 flags, bool lvalue)
 {
     bool padtmp = 0;
     PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
@@ -2046,7 +2051,10 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla
     if (gimme == G_SCALAR) {
        if (MARK < SP)
            *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
-                           ? *SP : sv_mortalcopy(*SP);
+                           ? *SP
+                           : lvalue
+                               ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
+                               : sv_mortalcopy(*SP);
        else {
            /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
            MARK = newsp;
@@ -2061,7 +2069,9 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla
            if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
                *++newsp = *MARK;
            else {
-               *++newsp = sv_mortalcopy(*MARK);
+               *++newsp = lvalue
+                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
+                           : sv_mortalcopy(*MARK);
                TAINT_NOT;      /* Each item is independent */
            }
        }
@@ -2104,7 +2114,8 @@ PP(pp_leave)
     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
 
     TAINT_NOT;
-    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
+    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
+                              PL_op->op_private & OPpLVALUE);
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
     LEAVE_with_name("block");
@@ -2266,7 +2277,7 @@ PP(pp_leaveloop)
     newsp = PL_stack_base + cx->blk_loop.resetsp;
 
     TAINT_NOT;
-    SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
+    SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0, FALSE);
     PUTBACK;
 
     POPLOOP(cx);       /* Stack values are safe: release loop vars ... */
@@ -4315,7 +4326,7 @@ PP(pp_leaveeval)
 
     TAINT_NOT;
     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
-                               gimme, SVs_TEMP);
+                               gimme, SVs_TEMP, FALSE);
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
 #ifdef DEBUGGING
@@ -4413,7 +4424,8 @@ PP(pp_leavetry)
     PERL_UNUSED_VAR(optype);
 
     TAINT_NOT;
-    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
+    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
+                              SVs_PADTMP|SVs_TEMP, FALSE);
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
     LEAVE_with_name("eval_scope");
@@ -4459,7 +4471,8 @@ PP(pp_leavegiven)
     assert(CxTYPE(cx) == CXt_GIVEN);
 
     TAINT_NOT;
-    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
+    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
+                              SVs_PADTMP|SVs_TEMP, FALSE);
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
     LEAVE_with_name("given");
@@ -5037,7 +5050,8 @@ PP(pp_leavewhen)
     assert(CxTYPE(cx) == CXt_WHEN);
 
     TAINT_NOT;
-    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
+    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
+                              SVs_PADTMP|SVs_TEMP, FALSE);
     PL_curpm = newpm;   /* pop $1 et al */
 
     LEAVE_with_name("when");

diff --git a/proto.h b/proto.h
index b81b526c3f88b8f7ad1e7cba5deb94a2ccc7615f..fef0bd419d1c14948ea0933bfeaa5a14e78bbe20 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6241,7 +6241,7 @@ PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, co
 
 #endif
 #if defined(PERL_IN_PP_CTL_C)
-STATIC SV **   S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
+STATIC SV **   S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags, bool lvalue)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3);

diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index 489583e408e6f47b5ddb47d53593c256fe501a29..acc9ecbe7d4ca06fcb632b19685fe5f64d2b5b27 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=>193;
+plan tests=>201;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -972,3 +972,39 @@ for (sub : lvalue { "$x" }->()) {
 eval { &{\&utf8::is_utf8}("") = 3 };
 like $@, qr/^Can't modify non-lvalue subroutine call at /,
         'XSUB not seen at compile time dies in lvalue context';
+
+# [perl #119797] else implicitly returning value
+# This used to cause Bizarre copy of ARRAY in pp_leave
+sub else119797 : lvalue {
+    if ($_[0]) {
+       1; # two statements force a leave op
+       @119797
+    }
+    else {
+       @119797
+    }
+}
+eval { (else119797(0)) = 1..3 };
+is $@, "", '$@ after writing to array returned by else';
+is "@119797", "1 2 3", 'writing to array returned by else';
+eval { (else119797(1)) = 4..6 };
+is $@, "", '$@ after writing to array returned by if (with else)';
+is "@119797", "4 5 6", 'writing to array returned by if (with else)';
+sub if119797 : lvalue {
+    if ($_[0]) {
+       @119797
+    }
+}
+@119797 = ();
+eval { (if119797(1)) = 4..6 };
+is $@, "", '$@ after writing to array returned by if';
+is "@119797", "4 5 6", 'writing to array returned by if';
+sub unless119797 : lvalue {
+    unless ($_[0]) {
+       @119797
+    }
+}
+@119797 = ();
+eval { (unless119797(0)) = 4..6 };
+is $@, "", '$@ after writing to array returned by unless';
+is "@119797", "4 5 6", 'writing to array returned by unless';