diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | op.c | 11 | ||||
| -rw-r--r-- | pp_ctl.c | 32 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | t/op/sub_lval.t | 38 |
6 files changed, 74 insertions, 14 deletions
@@ -1955,7 +1955,8 @@ sR |PerlIO *|check_type_and_open|NN SV *name #ifndef PERL_DISABLE_PMC sR |PerlIO *|doopen_pm |NN SV *name #endif -s |SV ** |adjust_stack_on_leave|NN SV **newsp|NN SV **sp|NN SV **mark|I32 gimme|U32 flags +s |SV ** |adjust_stack_on_leave|NN SV **newsp|NN SV **sp|NN SV **mark|I32 gimme \ + |U32 flags|bool lvalue iRn |bool |path_is_searchable|NN const char *name sR |I32 |run_user_filter|int idx|NN SV *buf_sv|int maxlen sR |PMOP* |make_matcher |NN REGEXP* re @@ -1516,7 +1516,7 @@ #define refto(a) S_refto(aTHX_ a) # endif # if defined(PERL_IN_PP_CTL_C) -#define adjust_stack_on_leave(a,b,c,d,e) S_adjust_stack_on_leave(aTHX_ a,b,c,d,e) +#define adjust_stack_on_leave(a,b,c,d,e,f) S_adjust_stack_on_leave(aTHX_ a,b,c,d,e,f) #define check_type_and_open(a) S_check_type_and_open(aTHX_ a) #define destroy_matcher(a) S_destroy_matcher(aTHX_ a) #define do_smartmatch(a,b,c) S_do_smartmatch(aTHX_ a,b,c) @@ -2252,8 +2252,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) PL_modcount++; break; - case OP_SCOPE: case OP_LEAVE: + o->op_private |= OPpLVALUE; + case OP_SCOPE: case OP_ENTER: case OP_LINESEQ: localize = 0; @@ -2288,6 +2289,14 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_COREARGS: return o; + + case OP_AND: + case OP_OR: + if (type == OP_LEAVESUBLV) { + op_lvalue(cLOGOPo->op_first, type); + op_lvalue(cLOGOPo->op_first->op_sibling, type); + } + goto nomod; } /* [20011101.069] File test operators interpret OPf_REF to mean that @@ -2033,8 +2033,13 @@ PP(pp_dbstate) return NORMAL; } +/* SVs on the stack that have any of the flags passed in are left as is. + Other SVs are protected via the mortals stack if lvalue is true, and + copied otherwise. */ + STATIC SV ** -S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) +S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, + U32 flags, bool lvalue) { bool padtmp = 0; PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; @@ -2046,7 +2051,10 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla if (gimme == G_SCALAR) { if (MARK < SP) *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP))) - ? *SP : sv_mortalcopy(*SP); + ? *SP + : lvalue + ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) + : sv_mortalcopy(*SP); else { /* MEXTEND() only updates MARK, so reuse it instead of newsp. */ MARK = newsp; @@ -2061,7 +2069,9 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK))) *++newsp = *MARK; else { - *++newsp = sv_mortalcopy(*MARK); + *++newsp = lvalue + ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)) + : sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } } @@ -2104,7 +2114,8 @@ PP(pp_leave) gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, + PL_op->op_private & OPpLVALUE); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("block"); @@ -2266,7 +2277,7 @@ PP(pp_leaveloop) newsp = PL_stack_base + cx->blk_loop.resetsp; TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0); + SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0, FALSE); PUTBACK; POPLOOP(cx); /* Stack values are safe: release loop vars ... */ @@ -4315,7 +4326,7 @@ PP(pp_leaveeval) TAINT_NOT; SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, - gimme, SVs_TEMP); + gimme, SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ #ifdef DEBUGGING @@ -4413,7 +4424,8 @@ PP(pp_leavetry) PERL_UNUSED_VAR(optype); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("eval_scope"); @@ -4459,7 +4471,8 @@ PP(pp_leavegiven) assert(CxTYPE(cx) == CXt_GIVEN); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("given"); @@ -5037,7 +5050,8 @@ PP(pp_leavewhen) assert(CxTYPE(cx) == CXt_WHEN); TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* pop $1 et al */ LEAVE_with_name("when"); @@ -6241,7 +6241,7 @@ PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, co #endif #if defined(PERL_IN_PP_CTL_C) -STATIC SV ** S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) +STATIC SV ** S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags, bool lvalue) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index 489583e408..acc9ecbe7d 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=>193; +plan tests=>201; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } @@ -972,3 +972,39 @@ for (sub : lvalue { "$x" }->()) { eval { &{\&utf8::is_utf8}("") = 3 }; like $@, qr/^Can't modify non-lvalue subroutine call at /, 'XSUB not seen at compile time dies in lvalue context'; + +# [perl #119797] else implicitly returning value +# This used to cause Bizarre copy of ARRAY in pp_leave +sub else119797 : lvalue { + if ($_[0]) { + 1; # two statements force a leave op + @119797 + } + else { + @119797 + } +} +eval { (else119797(0)) = 1..3 }; +is $@, "", '$@ after writing to array returned by else'; +is "@119797", "1 2 3", 'writing to array returned by else'; +eval { (else119797(1)) = 4..6 }; +is $@, "", '$@ after writing to array returned by if (with else)'; +is "@119797", "4 5 6", 'writing to array returned by if (with else)'; +sub if119797 : lvalue { + if ($_[0]) { + @119797 + } +} +@119797 = (); +eval { (if119797(1)) = 4..6 }; +is $@, "", '$@ after writing to array returned by if'; +is "@119797", "4 5 6", 'writing to array returned by if'; +sub unless119797 : lvalue { + unless ($_[0]) { + @119797 + } +} +@119797 = (); +eval { (unless119797(0)) = 4..6 }; +is $@, "", '$@ after writing to array returned by unless'; +is "@119797", "4 5 6", 'writing to array returned by unless'; |