diff options
| -rw-r--r-- | pod/perldelta.pod | 10 | ||||
| -rw-r--r-- | pp_ctl.c | 66 | ||||
| -rw-r--r-- | t/op/sub_lval.t | 51 |
3 files changed, 120 insertions, 7 deletions
diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 2a94ed9dd3..1964832ab4 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -377,6 +377,16 @@ not apply it. L<attributes.pm|attributes> has likewise been updated to warn and not apply the attribute. +=item * + +The remaining discrepancies between explicit and implicit return from +lvalue subroutines have been resolved. They mainly involved which error +message to display when a read-only value is returned in lvalue context. +Also, returning a PADTMP (the result of most built-ins, like C<index>) in +lvalue context is now forbidden for explicit return, as it always has been +for implicit return. This is not a regression from 5.14, as all the cases +in which it could happen where previously syntax errors. + =back =head1 Known Problems @@ -2224,11 +2224,50 @@ PP(pp_leaveloop) STATIC void S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, - PERL_CONTEXT *cx) + PERL_CONTEXT *cx, PMOP *newpm) { const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); if (gimme == G_SCALAR) { - if (MARK < SP) { + if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */ + SV *sv; + if (MARK < SP) { + assert(MARK+1 == SP); + if ((SvPADTMP(TOPs) || + (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE)) + == SVf_READONLY + ) && + !SvSMAGICAL(TOPs)) { + LEAVE; + cxstack_ix--; + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVESUB(sv); + Perl_croak(aTHX_ + "Can't return %s from lvalue subroutine", + SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" + : "a readonly value" : "a temporary"); + } + else { /* Can be a localized value + EXTEND_MORTAL(1); * subject to deletion. */ + PL_tmps_stack[++PL_tmps_ix] = *SP; + SvREFCNT_inc_void(*SP); + *++newsp = *SP; + } + } + else { + /* sub:lvalue{} will take us here. */ + LEAVE; + cxstack_ix--; + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVESUB(sv); + Perl_croak(aTHX_ + /* diag_listed_as: Can't return %s from lvalue subroutine*/ + "Can't return undef from lvalue subroutine" + ); + } + } + else if (MARK < SP) { if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { *++newsp = SvREFCNT_inc(*SP); FREETMPS; @@ -2270,7 +2309,26 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, ? sv_mortalcopy(*MARK) : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); else while (++MARK <= SP) { - *++newsp = *MARK; + if (*MARK != &PL_sv_undef + && (SvPADTMP(*MARK) + || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE)) + == SVf_READONLY + ) + ) { + SV *sv; + /* Might be flattened array after $#array = */ + PUTBACK; + LEAVE; + cxstack_ix--; + POPSUB(cx,sv); + PL_curpm = newpm; + LEAVESUB(sv); + Perl_croak(aTHX_ + "Can't return a %s from lvalue subroutine", + SvREADONLY(TOPs) ? "readonly value" : "temporary"); + } + else + *++newsp = *MARK; } } PL_stack_sp = newsp; @@ -2356,7 +2414,7 @@ PP(pp_return) } TAINT_NOT; - if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx); + if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm); else { if (gimme == G_SCALAR) { if (MARK < SP) { diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index 7534b98003..a4d518f27c 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=>160; +plan tests=>165; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } @@ -211,6 +211,7 @@ like($_, qr/Can\'t modify non-lvalue subroutine call/) or diag "'$_', '$x0', '$x1'"; sub lv0 : lvalue { } +sub rlv0 : lvalue { return } $_ = undef; eval <<'EOE' or $_ = $@; @@ -222,12 +223,29 @@ like($_, qr/Can't return undef from lvalue subroutine/); $_ = undef; eval <<'EOE' or $_ = $@; + rlv0 = (2,3); + 1; +EOE + +like($_, qr/Can't return undef from lvalue subroutine/, + 'explicit return of nothing in scalar context'); + +$_ = undef; +eval <<'EOE' or $_ = $@; (lv0) = (2,3); 1; EOE ok(!defined $_) or diag $_; +$_ = undef; +eval <<'EOE' or $_ = $@; + (rlv0) = (2,3); + 1; +EOE + +ok(!defined $_, 'explicit return of nothing in list context') or diag $_; + ($a,$b)=(); (lv0($a,$b)) = (3,4); is +($a//'undef') . ($b//'undef'), 'undefundef', @@ -235,6 +253,7 @@ is +($a//'undef') . ($b//'undef'), 'undefundef', sub lv1u :lvalue { undef } +sub rlv1u :lvalue { undef } $_ = undef; eval <<'EOE' or $_ = $@; @@ -246,6 +265,15 @@ like($_, qr/Can't return undef from lvalue subroutine/); $_ = undef; eval <<'EOE' or $_ = $@; + rlv1u = (2,3); + 1; +EOE + +like($_, qr/Can't return undef from lvalue subroutine/, + 'explicitly returning undef in scalar context'); + +$_ = undef; +eval <<'EOE' or $_ = $@; (lv1u) = (2,3); 1; EOE @@ -267,6 +295,25 @@ EOE like($_, qr/Can\'t return a temporary from lvalue subroutine/); $_ = undef; +eval <<'EOE' or $_ = $@; + sub rlv1t : lvalue { index $x, 2 } + rlv1t = (2,3); + 1; +EOE + +like($_, qr/Can\'t return a temporary from lvalue subroutine/, + 'returning a PADTMP explicitly'); + +$_ = undef; +eval <<'EOE' or $_ = $@; + (rlv1t) = (2,3); + 1; +EOE + +like($_, qr/Can\'t return a temporary from lvalue subroutine/, + 'returning a PADTMP explicitly (list context)'); + +$_ = undef; sub lv2t : lvalue { shift } (lv2t($_)) = (2,3); is($_, 2); @@ -744,14 +791,12 @@ is $ambaga, 74, 'explicit return of arbitrary expression (list context)'; is $ambaga, 73, 'implicit return of arbitrary expression (scalar context)'; (sub :lvalue { $ambaga || $ambaga }->()) = 74; is $ambaga, 74, 'implicit return of arbitrary expression (list context)'; -{ local $::TODO = 'return needs to enforce the same rules as leavesublv'; eval { +sub :lvalue { return 3 }->() = 4 }; like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, 'assignment to numeric constant explicitly returned from lv sub'; eval { (sub :lvalue { return 3 }->()) = 4 }; like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, 'assignment to num constant explicitly returned (list cx)'; -} eval { +sub :lvalue { 3 }->() = 4 }; like $@, qr/Can\'t return a readonly value from lvalue subroutine at/, 'assignment to numeric constant implicitly returned from lv sub'; |