From bf8fb5ebdd40c5dae131bdfb08395be447f81573 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Wed, 1 Jun 2011 16:37:17 -0700 Subject: [PATCH] [perl #62498] Scalar context breaks lvalue subs MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 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 --- pp_hot.c | 29 ++++++----------------------- t/op/sub_lval.t | 27 ++++++++++++++++++++++++++- t/re/pat_rt_report.t | 5 ++--- 3 files changed, 34 insertions(+), 27 deletions(-) diff --git a/pp_hot.c b/pp_hot.c index 9dffb98..ac915b4 100644 --- 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 --- 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 --- 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: $@"; } } -- 2.7.4