Fix several array-returning bugs in lvalue subs

This finishes fixing bug #23790.

When called in reference context (for(...) or map $_, ...), lvalue
subs returning arrays or hashes would return the AV or HV itself, as
though it were lvalue context.

The result was that $_ would be bound to an AV or HV, which is not
supposed to happen, as it’s a scalar (that’s when you start getting
‘Bizarre copy’ errors).

Commit 91e34d82 fixed this in pp_leavesublv, but the if condition it
added was placed outside the loop, so it only applied when the array
was the first thing returned. It also did not take hashes into account.

By changing the lvalue-context check in pp_padav, pp_padhv and
pp_rv2av (which also serves as pp_rv2hv), I was able to apply a more
general fix, which also fix another bug: Those array and hash ops were
croaking when called in scalar reference context (...->$method).

Because it is no longer part of the sub-leaving code, explicitly
returning an array in reference context works now, too.

This commit also eliminates the code added by 91e34d82, as it’s no
longer necessary.

diff --git a/pp.c b/pp.c
index 9579503..3673abd 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -71,11 +71,14 @@ PP(pp_padav)
     if (PL_op->op_flags & OPf_REF) {
        PUSHs(TARG);
        RETURN;
-    } else if (LVRET) {
+    } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+       const I32 flags = is_lvalue_sub();
+       if (flags && !(flags & OPpENTERSUB_INARGS)) {
        if (GIMME == G_SCALAR)
            Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
        PUSHs(TARG);
        RETURN;
+       }
     }
     gimme = GIMME_V;
     if (gimme == G_ARRAY) {
@@ -114,10 +117,13 @@ PP(pp_padhv)
            SAVECLEARSV(PAD_SVl(PL_op->op_targ));
     if (PL_op->op_flags & OPf_REF)
        RETURN;
-    else if (LVRET) {
+    else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+      const I32 flags = is_lvalue_sub();
+      if (flags && !(flags & OPpENTERSUB_INARGS)) {
        if (GIMME == G_SCALAR)
            Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
        RETURN;
+      }
     }
     gimme = GIMME_V;
     if (gimme == G_ARRAY) {

diff --git a/pp_hot.c b/pp_hot.c
index 7d0c6ec..34c493b 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -831,11 +831,14 @@ PP(pp_rv2av)
            SETs(sv);
            RETURN;
        }
-       else if (LVRET) {
+       else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+         const I32 flags = is_lvalue_sub();
+         if (flags && !(flags & OPpENTERSUB_INARGS)) {
            if (gimme != G_ARRAY)
                goto croak_cant_return;
            SETs(sv);
            RETURN;
+         }
        }
        else if (PL_op->op_flags & OPf_MOD
                && PL_op->op_private & OPpLVAL_INTRO)
@@ -873,11 +876,14 @@ PP(pp_rv2av)
                SETs(sv);
                RETURN;
            }
-           else if (LVRET) {
+           else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+             const I32 flags = is_lvalue_sub();
+             if (flags && !(flags & OPpENTERSUB_INARGS)) {
                if (gimme != G_ARRAY)
                    goto croak_cant_return;
                SETs(sv);
                RETURN;
+             }
            }
        }
     }
@@ -2685,28 +2691,6 @@ PP(pp_leavesublv)
            goto rvalue;
        if (gimme == G_ARRAY) {
            mark = newsp + 1;
-           /* We want an array here, but padav will have left us an arrayref for an lvalue,
-            * so we need to expand it */
-           if(SvTYPE(*mark) == SVt_PVAV) {
-               AV *const av = MUTABLE_AV(*mark);
-               const I32 maxarg = AvFILL(av) + 1;
-               (void)POPs; /* get rid of the array ref */
-               EXTEND(SP, maxarg);
-               if (SvRMAGICAL(av)) {
-                   U32 i;
-                   for (i=0; i < (U32)maxarg; i++) {
-                       SV ** const svp = av_fetch(av, i, FALSE);
-                       SP[i+1] = svp
-                           ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
-                           : &PL_sv_undef;
-                   }
-               }
-               else {
-                   Copy(AvARRAY(av), SP+1, maxarg, SV*);
-               }
-               SP += maxarg;
-               PUTBACK;
-           }
            if (!CvLVALUE(cx->blk_sub.cv))
                goto rvalue_array;
            EXTEND_MORTAL(SP - newsp);

diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index e246336..db9806b 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=>133;
+plan tests=>149;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -333,6 +333,15 @@ EOE
 
 is("'@a' $_", "'2 3' ");
 
+is lva->${\sub { return $_[0] }}, 2,
+  'lvalue->$thing when lvalue returns array';
+
+my @my = qw/ a b c /;
+sub lvmya : lvalue { @my }
+
+is lvmya->${\sub { return $_[0] }}, 3,
+  'lvalue->$thing when lvalue returns lexical array';
+
 sub lv1n : lvalue { $newvar }
 
 $_ = undef;
@@ -608,6 +617,61 @@ is ($Tie_Array::val[0], "value");
     sub changeme { $_[2] = "free" }
     changeme(lval_array);
     is("@arr", "one two free");
+
+    # test again, with explicit return
+    sub rlval_array() : lvalue {return @arr}
+    @arr  = qw /one two three/;
+    $line = "zero";
+    for (rlval_array) {
+        $line .= $_;
+    }
+    is($line, "zeroonetwothree");
+    is(trythislval(rlval_array()), "3xonetwothree");
+    changeme(rlval_array);
+    is("@arr", "one two free");
+
+    # Variations on the same theme, with multiple vars returned
+    my $scalar = 'half';
+    sub lval_scalar_array () : lvalue { $scalar, @arr }
+    @arr  = qw /one two three/;
+    $line = "zero";
+    for (lval_scalar_array) {
+        $line .= $_;
+    }
+    is($line, "zerohalfonetwothree");
+    is(trythislval(lval_scalar_array()), "4xhalfonetwothree");
+    changeme(lval_scalar_array);
+    is("@arr", "one free three");
+
+    sub lval_array_scalar () : lvalue { @arr, $scalar }
+    @arr  = qw /one two three/;
+    $line = "zero";
+    $scalar = 'four';
+    for (lval_array_scalar) {
+        $line .= $_;
+    }
+    is($line, "zeroonetwothreefour");
+    is(trythislval(lval_array_scalar()), "4xonetwothreefour");
+    changeme(lval_array_scalar);
+    is("@arr", "one two free");
+
+    # Tests for specific ops not tested above
+    # rv2av
+    @array2 = qw 'one two free';
+    is join(',', map $_, sub:lvalue{@array2}->()), 'one,two,free',
+      'rv2av in reference context';
+    is join(',', map $_, sub:lvalue{@{\@array2}}->()), 'one,two,free',
+      'rv2av-with-ref in reference context';
+    # padhv
+    my %hash = qw[a b c d];
+    like join(',', map $_, sub:lvalue{%hash}->()),
+         qr/^(?:a,b,c,d|c,d,a,b)\z/, 'padhv in reference context';
+    # rv2hv
+    %hash2 = qw[a b c d];
+    like join(',', map $_, sub:lvalue{%hash2}->()),
+         qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv in reference context';
+    like join(',', map $_, sub:lvalue{%{\%hash2}}->()),
+         qr/^(?:a,b,c,d|c,d,a,b)\z/, 'rv2hv-with-ref in reference context';
 }
 
 {