[perl #62498] Scalar context breaks lvalue subs

That RT ticket reported that a $ prototype puts an implicit scalar()
on its argument, and that scalar(lvalue()) causes the function to
return a temporary value. In particular:

  ${\scalar($_)} = 1; # ok
  ${\scalar f()} = 1; # no effect

(where f is an lvalue sub that returns $_).

It turns out that this does not only affect scalar(), but also
|| and &&:

  ${\($_  && undef)} = 3; # ok
  ${\(f() && undef)} = 3; # no effect

Also, that comment in pp_leavesublv about f()->meth() not being lvalue
context is wrong, as

  $o->${\sub { $_[0] = "whatever" }};

assigns to $o, and

  sub UNIVERSAL::undef { undef $_[0] }

allows calls like

  $x->undef

to undefine $x, if it contains an object or package name.

Since copying values in rvalue context is wasteful anyway, since the
definition of rvalue context is that the value is going to be copied
(resulting in *two* copies), the easiest solution is not to copy val-
ues in rvalue context.

This ends up applying to what I call ‘reference’ context (semi-lvalue,
or potential lvalue) as well.

This works already with explicit return.

As a bonus, this also fixes bug #78680, for which there are already
to-do tests that were added before the bug was reported. See also:

http://www.nntp.perl.org/group/perl.perl5.porters/;msgid=20060118203058.GQ616@plum.flirble.org

diff --git a/pp_hot.c b/pp_hot.c
index 9dffb98..ac915b4 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2673,10 +2673,9 @@ PP(pp_leavesublv)
         * subroutines too, so be backward compatible:
         * cannot report errors.  */
 
-       /* Scalar context *is* possible, on the LHS of -> only,
-        * as in f()->meth().  But this is not an lvalue. */
+       /* Scalar context *is* possible, on the LHS of ->. */
        if (gimme == G_SCALAR)
-           goto temporise;
+           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,
@@ -2702,7 +2701,7 @@ PP(pp_leavesublv)
                PUTBACK;
            }
            if (!CvLVALUE(cx->blk_sub.cv))
-               goto temporise_array;
+               goto rvalue_array;
            EXTEND_MORTAL(SP - newsp);
            for (mark = newsp + 1; mark <= SP; mark++) {
                if (SvTEMP(*mark))
@@ -2801,24 +2800,16 @@ PP(pp_leavesublv)
     }
     else {
        if (gimme == G_SCALAR) {
-         temporise:
+         rvalue:
            MARK = newsp + 1;
            if (MARK <= SP) {
                if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
-                   if (SvTEMP(TOPs)) {
                        *MARK = SvREFCNT_inc(TOPs);
                        FREETMPS;
                        sv_2mortal(*MARK);
-                   }
-                   else {
-                       sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
-                       FREETMPS;
-                       *MARK = sv_mortalcopy(sv);
-                       SvREFCNT_dec(sv);
-                   }
                }
                else
-                   *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+                   *MARK = TOPs;
            }
            else {
                MEXTEND(MARK, 0);
@@ -2826,16 +2817,8 @@ PP(pp_leavesublv)
            }
            SP = MARK;
        }
-       else if (gimme == G_ARRAY) {
-         temporise_array:
-           for (MARK = newsp + 1; MARK <= SP; MARK++) {
-               if (!SvTEMP(*MARK)) {
-                   *MARK = sv_mortalcopy(*MARK);
-                   TAINT_NOT;  /* Each item is independent */
-               }
-           }
-       }
     }
+  rvalue_array:
     PUTBACK;
 
     LEAVE;

diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index 5db4180..f490ec4 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=>108;
+plan tests=>124;
 
 sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
 sub b : lvalue { ${\shift} }
@@ -684,3 +684,28 @@ like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
 eval { (sub :lvalue { 3 }->()) = 4 };
 like $@, qr/Can\'t return a readonly value from lvalue subroutine at/,
       'assignment to num constant implicitly returned (list cx)';
+
+# reference (potential lvalue) context
+$suffix = '';
+for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) {
+    &$sub()->${\sub { $_[0] = 37 }};
+    is $_, '37', 'lvalue->method'.$suffix;
+    ${\scalar &$sub()} = 38;
+    is $_, '38', 'scalar(lvalue)'.$suffix;
+    sub assign39_with_proto ($) { $_[0] = 39 }
+    assign39_with_proto(&$sub());
+    is $_, '39', 'func(lvalue) when func has $ proto'.$suffix;
+    $_ = 1;
+    ${\(&$sub()||undef)} = 40;
+    is $_, '40', 'lvalue||...'.$suffix;
+    ${\(${\undef}||&$sub())} = 41; # extra ${\...} to bypass const folding
+    is $_, '41', '...||lvalue'.$suffix;
+    $_ = 0;
+    ${\(&$sub()&&undef)} = 42;
+    is $_, '42', 'lvalue&&...'.$suffix;
+    ${\(${\1}&&&$sub())} = 43;
+    is $_, '43', '...&&lvalue'.$suffix;
+    ${\(&$sub())[0]} = 44;
+    is $_, '44', '(lvalue)[0]'.$suffix;
+}
+continue { $suffix = ' (explicit return)' }

diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
index 7a03e64..781a6da 100644 (file)
--- a/t/re/pat_rt_report.t
+++ b/t/re/pat_rt_report.t
@@ -534,7 +534,8 @@ sub run_tests {
     }
 
     {
-        local $::TODO = "See changes 26925-26928, which reverted change 26410";
+        # [perl #78680]
+        # See changes 26925-26928, which reverted change 26410
         {
             package lv;
             our $var = "abc";
@@ -552,7 +553,6 @@ sub run_tests {
             is($f, "ab", "pos() retained between calls");
         }
         else {
-            local $::TODO;
             ok 0, "Code failed: $@";
         }
 
@@ -569,7 +569,6 @@ sub run_tests {
             is($g, "ab", "pos() retained between calls");
         }
         else {
-            local $::TODO;
             ok 0, "Code failed: $@";
         }
     }