In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/730fb7e791962b4f698b07b82ae1213ced61a5e1?hp=37395ff5f2b5fa17c5b7cebede056b6742e28e46>
- Log ----------------------------------------------------------------- commit 730fb7e791962b4f698b07b82ae1213ced61a5e1 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 22 23:04:02 2011 -0700 Fix up some tests in sub_lval.t One test was disabled long ago Returning undef in list context was allowed by change 10777 (f206cdd) in 2001. There was already a test for disallowing it. That test was disabled by change 10779 (4c8a4e58), rather than correct to test the new behaviour. This commit changes it to test that undef return is allowed in list context, also adding a test for explicit return. M t/op/sub_lval.t commit d25b0d7b851633ad047adf5acb71da838d99de68 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 22 22:58:45 2011 -0700 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. M pod/perldelta.pod M pp_ctl.c M t/op/sub_lval.t commit 50e9a4a73ae0d7fd56e72d5cd3befa63d9ebaa7b Author: Father Chrysostomos <[email protected]> Date: Wed Jun 22 19:03:32 2011 -0700 pp_leavesublv: Put the deref code inside if(scalar) No need to check it in list context (but still assert that). M pp_ctl.c commit 943d76f23b94ab9adf16ba9537d0c969a62828c6 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 22 18:59:02 2011 -0700 Make pp_leavesublv switch based on gimme Put if(gimme == ...) on the outside and if(CxLVAL(cx)...) on the inside. This reduces the amount of code, since the OPpENTERSUB_INARGS case and the !CxLVAL case were both doing the same thing for scalars. M pp_ctl.c commit 18beaace84297ebbc2de887d89c743e3502c0cd2 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 22 18:39:10 2011 -0700 Removed unused label from pp_leavesublv This has been unused since e178c744. M pp_ctl.c commit 80422e24c8b2c134c9ee2ac7d87aa9f750192f20 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 22 18:37:59 2011 -0700 Copy PADTMPs explicitly returned from lv subs I donât believe this changes any observable behaviour, Devel::Peek aside. If it does, it fixes bugs. I am making this change for two reasons: ⢠PADTMPs can be a bit buggy and letting them escape their subroutines can make the bugs harder to fix. ⢠This brings explicit and implicit return from lvalue subroutines one step closer (for the sake of merging the code). M pp_ctl.c ----------------------------------------------------------------------- Summary of changes: pod/perldelta.pod | 10 +++ pp_ctl.c | 203 +++++++++++++++++++++++++++++++++-------------------- t/op/sub_lval.t | 64 +++++++++++++++-- 3 files changed, 195 insertions(+), 82 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<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 diff --git a/pp_ctl.c b/pp_ctl.c index 4324253..0016484 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2224,10 +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; @@ -2260,14 +2300,35 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, } else if (gimme == G_ARRAY) { assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF)); - if (!CxLVAL(cx) || CxLVAL(cx) & OPpENTERSUB_INARGS) + if (ref || !CxLVAL(cx)) while (++MARK <= SP) *++newsp = SvTEMP(*MARK) ? *MARK - : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); + : ref && SvFLAGS(*MARK) & SVs_PADTMP + ? 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; @@ -2353,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) { @@ -2433,33 +2494,9 @@ PP(pp_leavesublv) TAINT_NOT; - if (CxLVAL(cx) & OPpENTERSUB_INARGS) { - /* We are an argument to a function or grep(). - * This kind of lvalueness was legal before lvalue - * subroutines too, so be backward compatible: - * cannot report errors. */ - - /* Scalar context *is* possible, on the LHS of ->. */ - if (gimme == G_SCALAR) - goto rvalue; - if (gimme == G_ARRAY) { - mark = newsp + 1; - EXTEND_MORTAL(SP - newsp); - for (mark = newsp + 1; mark <= SP; mark++) { - if (SvTEMP(*mark)) - NOOP; - else if (SvFLAGS(*mark) & SVs_PADTMP) - *mark = sv_mortalcopy(*mark); - else { - /* Can be a localized value subject to deletion. */ - PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc_void(*mark); - } - } - } - } - else if (CxLVAL(cx)) { /* Leave it as it is if we can. */ - if (gimme == G_SCALAR) { + if (gimme == G_SCALAR) { + if (CxLVAL(cx) && !(CxLVAL(cx) & OPpENTERSUB_INARGS)) { + /* Leave it as it is if we can. */ MARK = newsp + 1; EXTEND_MORTAL(1); if (MARK == SP) { @@ -2502,7 +2539,63 @@ PP(pp_leavesublv) } SP = MARK; } - else if (gimme == G_ARRAY) { + else { + MARK = newsp + 1; + if (MARK <= SP) { + if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { + *MARK = SvREFCNT_inc(TOPs); + FREETMPS; + sv_2mortal(*MARK); + } + else + *MARK = SvTEMP(TOPs) + ? TOPs + : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs)); + } + else { + MEXTEND(MARK, 0); + *MARK = &PL_sv_undef; + } + SP = MARK; + } + if (CxLVAL(cx) & OPpENTERSUB_DEREF) { + SvGETMAGIC(TOPs); + if (!SvOK(TOPs)) { + U8 deref_type; + if (cx->blk_sub.retop->op_type == OP_RV2SV) + deref_type = OPpDEREF_SV; + else if (cx->blk_sub.retop->op_type == OP_RV2AV) + deref_type = OPpDEREF_AV; + else { + assert(cx->blk_sub.retop->op_type == OP_RV2HV); + deref_type = OPpDEREF_HV; + } + vivify_ref(TOPs, deref_type); + } + } + } + else if (gimme == G_ARRAY) { + assert(!(CxLVAL(cx) & OPpENTERSUB_DEREF)); + if (CxLVAL(cx) & OPpENTERSUB_INARGS) { + /* We are an argument to a function or grep(). + * This kind of lvalueness was legal before lvalue + * subroutines too, so be backward compatible: + * cannot report errors. */ + mark = newsp + 1; + EXTEND_MORTAL(SP - newsp); + for (mark = newsp + 1; mark <= SP; mark++) { + if (SvTEMP(*mark)) + NOOP; + else if (SvFLAGS(*mark) & SVs_PADTMP) + *mark = sv_mortalcopy(*mark); + else { + /* Can be a localized value subject to deletion. */ + PL_tmps_stack[++PL_tmps_ix] = *mark; + SvREFCNT_inc_void(*mark); + } + } + } + else if (CxLVAL(cx)) { /* Leave it as it is if we can. */ EXTEND_MORTAL(SP - newsp); for (mark = newsp + 1; mark <= SP; mark++) { if (*mark != &PL_sv_undef @@ -2528,30 +2621,7 @@ PP(pp_leavesublv) } } } - } - else { - if (gimme == G_SCALAR) { - rvalue: - MARK = newsp + 1; - if (MARK <= SP) { - if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - *MARK = SvREFCNT_inc(TOPs); - FREETMPS; - sv_2mortal(*MARK); - } - else - *MARK = SvTEMP(TOPs) - ? TOPs - : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs)); - } - else { - MEXTEND(MARK, 0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else if (gimme == G_ARRAY) { - rvalue_array: + else { for (MARK = newsp + 1; MARK <= SP; MARK++) { if (!SvTEMP(*MARK)) *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); @@ -2559,23 +2629,6 @@ PP(pp_leavesublv) } } - if (CxLVAL(cx) & OPpENTERSUB_DEREF) { - assert(gimme == G_SCALAR); - SvGETMAGIC(TOPs); - if (!SvOK(TOPs)) { - U8 deref_type; - if (cx->blk_sub.retop->op_type == OP_RV2SV) - deref_type = OPpDEREF_SV; - else if (cx->blk_sub.retop->op_type == OP_RV2AV) - deref_type = OPpDEREF_AV; - else { - assert(cx->blk_sub.retop->op_type == OP_RV2HV); - deref_type = OPpDEREF_HV; - } - vivify_ref(TOPs, deref_type); - } - } - PUTBACK; LEAVE; diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index 7534b98..06ac461 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=>167; 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,14 +265,28 @@ 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 -# Fixed by change @10777 -#print "# '$_'.\nnot " -# unless /Can\'t return an uninitialized value from lvalue subroutine/; -# print "ok 34 # Skip: removed test\n"; +ok(!defined, 'implicitly returning undef in list context'); + +$_ = undef; +eval <<'EOE' or $_ = $@; + (rlv1u) = (2,3); + 1; +EOE + +ok(!defined, 'explicitly returning undef in list context'); $x = '1234567'; @@ -267,6 +300,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 +796,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'; -- Perl5 Master Repository
