From d25b0d7b851633ad047adf5acb71da838d99de68 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Wed, 22 Jun 2011 22:58:45 -0700 Subject: [PATCH] Make lvalue return make the same checks as leavesublv This causes explicit return in lvalue context to die the way implicit return does. See the tests and the perldelta entry in the diff. --- pod/perldelta.pod | 10 +++++++++ pp_ctl.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++---- t/op/sub_lval.t | 51 +++++++++++++++++++++++++++++++++++++++--- 3 files changed, 120 insertions(+), 7 deletions(-) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 2a94ed9..1964832 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -377,6 +377,16 @@ not apply it. L 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) 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 diff --git a/pp_ctl.c b/pp_ctl.c index 95f2856..0016484 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -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 7534b98..a4d518f 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'; -- 2.7.4