In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/4bee03f8e20d4e5257132fdea9f9fac4206c79f8?hp=ceb7f800743f9d0c3a2ed97d06aca722aab3c8b5>
- Log ----------------------------------------------------------------- commit 4bee03f8e20d4e5257132fdea9f9fac4206c79f8 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 09:44:45 2011 -0700 Fix explicit return of pad var in list lv context This is something that commit e08be60 missed, though it never worked properly, even in 5.14, as explicit return from lvalue subs used to copy return values. As the commit message for e08be60 states, returning a scalar itself from an lvalue sub does not work if it is a pad variable with a refer- ence count of 1, because the sub-popping code clears it on exit. The one code path that did not account for this was list lvalue con- text (real lvalue context, not just potentially lvalue). The only observable effect this has is that assigning to a magic pad variable returned from a subroutine in list context will not trigger set-magic. This commit fixes it and also adds tests for returned magic pad vars in all combinations of list/scalar lvalue/ref context. M pod/perldelta.pod M pp_ctl.c M t/op/sub_lval.t commit 0accd0eeebd92a8877c7f7ecc13c7cb3ec364faa Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 08:16:03 2011 -0700 Collapse the list context code in pp_leavesublv Two branches of this three-branch if/elsif were doing the same thing. One was written out longhand. M pp_ctl.c commit bf1857d8fffd6739904f9f8dfa5e615f46485383 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 06:16:12 2011 -0700 Remove now-redundant check from pp_ctl.c:S_return_lvalues This has been redundant since commit d25b0d7. M pp_ctl.c ----------------------------------------------------------------------- Summary of changes: pod/perldelta.pod | 13 +++++++++++++ pp_ctl.c | 39 ++++++++++++--------------------------- t/op/sub_lval.t | 26 +++++++++++++++++++++++++- 3 files changed, 50 insertions(+), 28 deletions(-) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 095785c..751da25 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -384,6 +384,9 @@ the attribute. =item * +=for comment +Not necessary for perl5160delta + 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. @@ -392,6 +395,16 @@ 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. +=item * + +=for comment +Not necessary for perl5160delta + +Explicitly returning a tied C<my> variable from an lvalue subroutine in +list lvalue context used to clear the variable before the assignment could +happen. This is something that was missed when explicit return was made to +work in 5.15.0. + =back =head1 Known Problems diff --git a/pp_ctl.c b/pp_ctl.c index 8e53116..36ba24a 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2282,7 +2282,6 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, } else *++newsp = - (!CxLVAL(cx) || CxLVAL(cx) & OPpENTERSUB_INARGS) && !SvTEMP(*SP) ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) : *SP; @@ -2335,7 +2334,10 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, SvREADONLY(TOPs) ? "readonly value" : "temporary"); } else - *++newsp = *MARK; + *++newsp = + SvTEMP(*MARK) + ? *MARK + : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); } } PL_stack_sp = newsp; @@ -2582,27 +2584,16 @@ PP(pp_leavesublv) } } else if (gimme == G_ARRAY) { + const bool ref = CxLVAL(cx) & OPpENTERSUB_INARGS; 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); - } + if (ref||!CxLVAL(cx)) + for (MARK = newsp + 1; MARK <= SP; MARK++) { + if (!SvTEMP(*MARK)) + *MARK = ref && SvFLAGS(*mark) & SVs_PADTMP + ? sv_mortalcopy(*mark) + : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); } - } - else if (CxLVAL(cx)) { /* Leave it as it is if we can. */ + else { /* Leave it as it is if we can. */ EXTEND_MORTAL(SP - newsp); for (mark = newsp + 1; mark <= SP; mark++) { if (*mark != &PL_sv_undef @@ -2628,12 +2619,6 @@ PP(pp_leavesublv) } } } - else { - for (MARK = newsp + 1; MARK <= SP; MARK++) { - if (!SvTEMP(*MARK)) - *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); - } - } } PUTBACK; diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index 06ac461..64e7b4e 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=>167; +plan tests=>175; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } @@ -556,6 +556,30 @@ is($@, "", "element of tied array"); is ($Tie_Array::val[0], "value"); +# Check that tied pad vars that are returned can be assigned to +sub TIESCALAR { bless [] } +sub STORE {$wheel = $_[1]} +sub FETCH {$wheel} +sub tied_pad_var :lvalue { tie my $tyre, ''; $tyre } +sub tied_pad_varr :lvalue { tie my $tyre, ''; return $tyre } +tied_pad_var = 1; +is $wheel, 1, 'tied pad var returned in scalar lvalue context'; +tied_pad_var->${\sub{ $_[0] = 2 }}; +is $wheel, 2, 'tied pad var returned in scalar ref context'; +(tied_pad_var) = 3; +is $wheel, 3, 'tied pad var returned in list lvalue context'; +$_ = 4 for tied_pad_var; +is $wheel, 4, 'tied pad var returned in list ref context'; +tied_pad_varr = 5; +is $wheel, 5, 'tied pad var explicitly returned in scalar lvalue context'; +tied_pad_varr->${\sub{ $_[0] = 6 }}; +is $wheel, 6, 'tied pad var explicitly returned in scalar ref context'; +(tied_pad_varr) = 7; +is $wheel, 7, 'tied pad var explicitly returned in list lvalue context'; +$_ = 8 for tied_pad_varr; +is $wheel, 8, 'tied pad var explicitly returned in list ref context'; + + # Test explicit return of lvalue expression { # subs are copies from tests 1-~18 with an explicit return added. -- Perl5 Master Repository
