X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/51eb35b5522d03b44aef29d0c17d1138ba8ed6fa..a375ceca5d834c83946967bb2d7972d7403acedb:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index e32a17e..e0caf6f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -142,7 +142,7 @@ PP(pp_regcomp) const bool was_tainted = TAINT_get; if (pm->op_flags & OPf_STACKED) lhs = args[-1]; - else if (pm->op_private & OPpTARGET_MY) + else if (pm->op_targ) lhs = PAD_SV(pm->op_targ); else lhs = DEFSV; SvGETMAGIC(lhs); @@ -210,7 +210,7 @@ PP(pp_substcont) rxres_restore(&cx->sb_rxres, rx); if (cx->sb_iters++) { - const I32 saviters = cx->sb_iters; + const SSize_t saviters = cx->sb_iters; if (cx->sb_iters > cx->sb_maxiters) DIE(aTHX_ "Substitution loop"); @@ -288,7 +288,7 @@ PP(pp_substcont) POPSUBST(cx); PERL_ASYNC_CHECK(); RETURNOP(pm->op_next); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } cx->sb_iters = saviters; } @@ -312,10 +312,16 @@ PP(pp_substcont) SV * const sv = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; MAGIC *mg; + + /* the string being matched against may no longer be a string, + * e.g. $_=0; s/.../$_++/ge */ + + if (!SvPOK(sv)) + SvPV_force_nomg_nolen(sv); + if (!(mg = mg_find_mglob(sv))) { mg = sv_magicext_mglob(sv); } - assert(SvPOK(sv)); MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig); } if (old != rx) @@ -586,6 +592,7 @@ PP(pp_formline) break; } itembytes = s - item; + chophere = s; break; } @@ -674,7 +681,7 @@ PP(pp_formline) goto append; case FF_CHOP: /* (for ^*) chop the current item */ - { + if (sv != &PL_sv_no) { const char *s = chophere; if (chopspace) { while (isSPACE(*s)) @@ -701,11 +708,11 @@ PP(pp_formline) const char *const send = s + len; item_is_utf8 = DO_UTF8(sv); + chophere = s + len; if (!len) break; trans = 0; gotsome = TRUE; - chophere = s + len; source = (U8 *) s; to_copy = len; while (s < send) { @@ -823,7 +830,8 @@ PP(pp_formline) { Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)); int len; - DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_SET_TO_NEEDED(); arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); #ifdef USE_QUADMATH { @@ -1109,7 +1117,7 @@ PP(pp_mapwhile) PP(pp_range) { - if (GIMME == G_ARRAY) + if (GIMME_V == G_ARRAY) return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) return cLOGOP->op_other; @@ -1121,7 +1129,7 @@ PP(pp_flip) { dSP; - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } else { @@ -1175,7 +1183,7 @@ PP(pp_flop) { dSP; - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { dPOPPOPssrl; SvGETMAGIC(left); @@ -1209,8 +1217,10 @@ PP(pp_flop) else n = 0; while (n--) { - SV * const sv = sv_2mortal(newSViv(i++)); + SV * const sv = sv_2mortal(newSViv(i)); PUSHs(sv); + if (n) /* avoid incrementing above IV_MAX */ + i++; } } else { @@ -1676,13 +1686,13 @@ Perl_die_unwind(pTHX_ SV *msv) PL_restartjmpenv = restartjmpenv; PL_restartop = restartop; JMPENV_JUMP(3); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } } write_to_stderr(exceptsv); my_failure_exit(); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } PP(pp_xor) @@ -1762,7 +1772,7 @@ PP(pp_caller) dSP; const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; - I32 gimme; + I32 gimme = GIMME_V; const HEK *stash_hek; I32 count = 0; bool has_arg = MAXARG && TOPs; @@ -1776,7 +1786,7 @@ PP(pp_caller) cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx); if (!cx) { - if (GIMME != G_ARRAY) { + if (gimme != G_ARRAY) { EXTEND(SP, 1); RETPUSHUNDEF; } @@ -1788,7 +1798,7 @@ PP(pp_caller) stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) : NULL; - if (GIMME != G_ARRAY) { + if (gimme != G_ARRAY) { EXTEND(SP, 1); if (!stash_hek) PUSHs(&PL_sv_undef); @@ -1810,7 +1820,7 @@ PP(pp_caller) PUSHTARG; } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); - lcop = closest_cop(cx->blk_oldcop, OP_SIBLING(cx->blk_oldcop), + lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop), cx->blk_sub.retop, TRUE); if (!lcop) lcop = cx->blk_oldcop; @@ -2088,6 +2098,28 @@ PP(pp_leave) RETURN; } +static bool +S_outside_integer(pTHX_ SV *sv) +{ + if (SvOK(sv)) { + const NV nv = SvNV_nomg(sv); + if (Perl_isinfnan(nv)) + return TRUE; +#ifdef NV_PRESERVES_UV + if (nv < (NV)IV_MIN || nv > (NV)IV_MAX) + return TRUE; +#else + if (nv <= (NV)IV_MIN) + return TRUE; + if ((nv > 0) && + ((nv > (NV)UV_MAX || + SvUV_nomg(sv) > (UV)IV_MAX))) + return TRUE; +#endif + } + return FALSE; +} + PP(pp_enteriter) { dSP; dMARK; @@ -2146,32 +2178,13 @@ PP(pp_enteriter) SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { - NV nv; cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYIV; /* Make sure that no-one re-orders cop.h and breaks our assumptions */ assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); -#ifdef NV_PRESERVES_UV - if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) || - (nv > (NV)IV_MAX))) - || - (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) || - (nv < (NV)IV_MIN)))) -#else - if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN) - || - ((nv > 0) && - ((nv > (NV)UV_MAX) || - (SvUV_nomg(sv) > (UV)IV_MAX))))) - || - (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN) - || - ((nv > 0) && - ((nv > (NV)UV_MAX) || - (SvUV_nomg(right) > (UV)IV_MAX)) - )))) -#endif + if (S_outside_integer(aTHX_ sv) || + S_outside_integer(aTHX_ right)) DIE(aTHX_ "Range iterator outside integer range"); cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); @@ -2266,17 +2279,46 @@ PP(pp_leaveloop) return NORMAL; } -STATIC void -S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, - PERL_CONTEXT *cx, PMOP *newpm) + +/* This duplicates most of pp_leavesub, but with additional code to handle + * return args in lvalue context. It was forked from pp_leavesub to + * avoid slowing down that function any further. + * + * Any changes made to this function may need to be copied to pp_leavesub + * and vice-versa. + */ + +PP(pp_leavesublv) { - const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); + dSP; + SV **newsp; + SV **mark; + PMOP *newpm; + I32 gimme; + PERL_CONTEXT *cx; + SV *sv; + bool ref; + const char *what = NULL; + + if (CxMULTICALL(&cxstack[cxstack_ix])) { + /* entry zero of a stack is always PL_sv_undef, which + * simplifies converting a '()' return into undef in scalar context */ + assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); + return 0; + } + + POPBLOCK(cx,newpm); + cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ + TAINT_NOT; + + mark = newsp + 1; + + ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS); if (gimme == G_SCALAR) { if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */ SV *sv; - const char *what = NULL; - if (MARK < SP) { - assert(MARK+1 == SP); + if (MARK <= SP) { + assert(MARK == SP); if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) && !SvSMAGICAL(TOPs)) { what = @@ -2289,33 +2331,34 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, /* sub:lvalue{} will take us here. */ what = "undef"; } + croak: LEAVE; - cxstack_ix--; POPSUB(cx,sv); + cxstack_ix--; PL_curpm = newpm; LEAVESUB(sv); Perl_croak(aTHX_ "Can't return %s from lvalue subroutine", what ); } - if (MARK < SP) { + if (MARK <= SP) { copy_sv: if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { if (!SvPADTMP(*SP)) { - *++newsp = SvREFCNT_inc(*SP); + *MARK = SvREFCNT_inc(*SP); FREETMPS; - sv_2mortal(*newsp); + sv_2mortal(*MARK); } else { /* FREETMPS could clobber it */ SV *sv = SvREFCNT_inc(*SP); FREETMPS; - *++newsp = sv_mortalcopy(sv); + *MARK = sv_mortalcopy(sv); SvREFCNT_dec(sv); } } else - *++newsp = + *MARK = SvPADTMP(*SP) ? sv_mortalcopy(*SP) : !SvTEMP(*SP) @@ -2323,9 +2366,11 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, : *SP; } else { - EXTEND(newsp,1); - *++newsp = &PL_sv_undef; + MEXTEND(MARK, 0); + *MARK = &PL_sv_undef; } + SP = MARK; + if (CxLVAL(cx) & OPpDEREF) { SvGETMAGIC(TOPs); if (!SvOK(TOPs)) { @@ -2336,55 +2381,43 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, else if (gimme == G_ARRAY) { assert (!(CxLVAL(cx) & OPpDEREF)); if (ref || !CxLVAL(cx)) - while (++MARK <= SP) - *++newsp = + for (; MARK <= SP; MARK++) + *MARK = SvFLAGS(*MARK) & SVs_PADTMP ? sv_mortalcopy(*MARK) : SvTEMP(*MARK) ? *MARK : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); - else while (++MARK <= SP) { + else for (; MARK <= SP; MARK++) { if (*MARK != &PL_sv_undef && (SvPADTMP(*MARK) || SvREADONLY(*MARK)) ) { - const bool ro = cBOOL( SvREADONLY(*MARK) ); - SV *sv; /* Might be flattened array after $#array = */ - PUTBACK; - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - /* diag_listed_as: Can't return %s from lvalue subroutine */ - Perl_croak(aTHX_ - "Can't return a %s from lvalue subroutine", - ro ? "readonly value" : "temporary"); + what = SvREADONLY(*MARK) + ? "a readonly value" : "a temporary"; + goto croak; } - else - *++newsp = - SvTEMP(*MARK) - ? *MARK - : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); + else if (!SvTEMP(*MARK)) + *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); } } - PL_stack_sp = newsp; + PUTBACK; + + LEAVE; + POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ + cxstack_ix--; + PL_curpm = newpm; /* ... and pop $1 et al */ + LEAVESUB(sv); + + return cx->blk_sub.retop; } + PP(pp_return) { dSP; dMARK; PERL_CONTEXT *cx; - bool popsub2 = FALSE; - bool clear_errsv = FALSE; - bool lval = FALSE; - I32 gimme; - SV **newsp; - PMOP *newpm; - I32 optype = 0; - SV *namesv; - SV *sv; - OP *retop = NULL; + SV **oldsp; const I32 cxix = dopoptosub(cxstack_ix); @@ -2393,8 +2426,12 @@ PP(pp_return) * sort block, which is a CXt_NULL * not a CXt_SUB */ dounwind(0); - PL_stack_base[1] = *PL_stack_sp; - PL_stack_sp = PL_stack_base + 1; + /* if we were in list context, we would have to splice out + * any junk before the return args, like we do in the general + * pp_return case, e.g. + * sub f { for (junk1, junk2) { return arg1, arg2 }} + */ + assert(cxstack[0].blk_gimme == G_SCALAR); return 0; } else @@ -2403,142 +2440,50 @@ PP(pp_return) if (cxix < cxstack_ix) dounwind(cxix); - if (CxMULTICALL(&cxstack[cxix])) { - gimme = cxstack[cxix].blk_gimme; - if (gimme == G_VOID) - PL_stack_sp = PL_stack_base; - else if (gimme == G_SCALAR) { - PL_stack_base[1] = *PL_stack_sp; - PL_stack_sp = PL_stack_base + 1; - } - return 0; + cx = &cxstack[cxix]; + + oldsp = PL_stack_base + cx->blk_oldsp; + if (oldsp != MARK) { + /* Handle extra junk on the stack. For example, + * for (1,2) { return 3,4 } + * leaves 1,2,3,4 on the stack. In list context we + * have to splice out the 1,2; In scalar context for + * for (1,2) { return } + * we need to set sp = oldsp so that pp_leavesub knows + * to push &PL_sv_undef onto the stack. + * Note that in pp_return we only do the extra processing + * required to handle junk; everything else we leave to + * pp_leavesub. + */ + SSize_t nargs = SP - MARK; + if (nargs) { + if (cx->blk_gimme == G_ARRAY) { + /* shift return args to base of call stack frame */ + Move(MARK + 1, oldsp + 1, nargs, SV**); + PL_stack_sp = oldsp + nargs; + } + } + else + PL_stack_sp = oldsp; } - POPBLOCK(cx,newpm); + /* fall through to a normal exit */ switch (CxTYPE(cx)) { - case CXt_SUB: - popsub2 = TRUE; - lval = !!CvLVALUE(cx->blk_sub.cv); - retop = cx->blk_sub.retop; - cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ - break; case CXt_EVAL: - if (!(PL_in_eval & EVAL_KEEPERR)) - clear_errsv = TRUE; - POPEVAL(cx); - namesv = cx->blk_eval.old_namesv; - retop = cx->blk_eval.retop; - if (CxTRYBLOCK(cx)) - break; - if (optype == OP_REQUIRE && - (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) ) - { - /* Unassume the success we assumed earlier. */ - (void)hv_delete(GvHVn(PL_incgv), - SvPVX_const(namesv), - SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), - G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv)); - } - break; + return CxTRYBLOCK(cx) + ? Perl_pp_leavetry(aTHX) + : Perl_pp_leaveeval(aTHX); + case CXt_SUB: + return CvLVALUE(cx->blk_sub.cv) + ? Perl_pp_leavesublv(aTHX) + : Perl_pp_leavesub(aTHX); case CXt_FORMAT: - retop = cx->blk_sub.retop; - POPFORMAT(cx); - break; + return Perl_pp_leavewrite(aTHX); default: DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx)); } - - TAINT_NOT; - if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm); - else { - if (gimme == G_SCALAR) { - if (MARK < SP) { - if (popsub2) { - if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1 - && !SvMAGICAL(TOPs)) { - *++newsp = SvREFCNT_inc(*SP); - FREETMPS; - sv_2mortal(*newsp); - } - else { - sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ - FREETMPS; - *++newsp = sv_mortalcopy(sv); - SvREFCNT_dec(sv); - } - } - else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1 - && !SvMAGICAL(*SP)) { - *++newsp = *SP; - } - else - *++newsp = sv_mortalcopy(*SP); - } - else - *++newsp = sv_mortalcopy(*SP); - } - else - *++newsp = &PL_sv_undef; - } - else if (gimme == G_ARRAY) { - while (++MARK <= SP) { - *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1 - && !SvGMAGICAL(*MARK) - ? *MARK : sv_mortalcopy(*MARK); - TAINT_NOT; /* Each item is independent */ - } - } - PL_stack_sp = newsp; - } - - LEAVE; - /* Stack values are safe: */ - if (popsub2) { - cxstack_ix--; - POPSUB(cx,sv); /* release CV and @_ ... */ - } - else - sv = NULL; - PL_curpm = newpm; /* ... and pop $1 et al */ - - LEAVESUB(sv); - if (clear_errsv) { - CLEAR_ERRSV(); - } - return retop; } -/* This duplicates parts of pp_leavesub, so that it can share code with - * pp_return */ -PP(pp_leavesublv) -{ - dSP; - SV **newsp; - PMOP *newpm; - I32 gimme; - PERL_CONTEXT *cx; - SV *sv; - - if (CxMULTICALL(&cxstack[cxstack_ix])) - return 0; - - POPBLOCK(cx,newpm); - cxstack_ix++; /* temporarily protect top context */ - - TAINT_NOT; - - S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm); - - LEAVE; - POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ - cxstack_ix--; - PL_curpm = newpm; /* ... and pop $1 et al */ - - LEAVESUB(sv); - return cx->blk_sub.retop; -} static I32 S_unwind_loop(pTHX_ const char * const opname) @@ -2582,42 +2527,23 @@ S_unwind_loop(pTHX_ const char * const opname) PP(pp_last) { PERL_CONTEXT *cx; - I32 pop2 = 0; I32 gimme; - I32 optype; OP *nextop = NULL; SV **newsp; PMOP *newpm; - SV *sv = NULL; S_unwind_loop(aTHX_ "last"); POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ - switch (CxTYPE(cx)) { - case CXt_LOOP_LAZYIV: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - case CXt_LOOP_PLAIN: - pop2 = CxTYPE(cx); - newsp = PL_stack_base + cx->blk_loop.resetsp; - nextop = cx->blk_loop.my_op->op_lastop->op_next; - break; - case CXt_SUB: - pop2 = CXt_SUB; - nextop = cx->blk_sub.retop; - break; - case CXt_EVAL: - POPEVAL(cx); - nextop = cx->blk_eval.retop; - break; - case CXt_FORMAT: - POPFORMAT(cx); - nextop = cx->blk_sub.retop; - break; - default: - DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx)); - } + assert( + CxTYPE(cx) == CXt_LOOP_LAZYIV + || CxTYPE(cx) == CXt_LOOP_LAZYSV + || CxTYPE(cx) == CXt_LOOP_FOR + || CxTYPE(cx) == CXt_LOOP_PLAIN + ); + newsp = PL_stack_base + cx->blk_loop.resetsp; + nextop = cx->blk_loop.my_op->op_lastop->op_next; TAINT_NOT; PL_stack_sp = newsp; @@ -2625,22 +2551,10 @@ PP(pp_last) LEAVE; cxstack_ix--; /* Stack values are safe: */ - switch (pop2) { - case CXt_LOOP_LAZYIV: - case CXt_LOOP_PLAIN: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_FOR: - POPLOOP(cx); /* release loop vars ... */ - LEAVE; - break; - case CXt_SUB: - POPSUB(cx,sv); /* release CV and @_ ... */ - break; - } + POPLOOP(cx); /* release loop vars ... */ + LEAVE; PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVESUB(sv); - PERL_UNUSED_VAR(optype); PERL_UNUSED_VAR(gimme); return nextop; } @@ -2709,7 +2623,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac if (o->op_flags & OPf_KIDS) { OP *kid; /* First try all the kids at this level, since that's likeliest. */ - for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { STRLEN kid_label_len; U32 kid_label_flags; @@ -2729,7 +2643,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac return kid; } } - for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { if (kid == PL_lastgotoprobe) continue; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { @@ -3017,13 +2931,13 @@ PP(pp_goto) case CXt_LOOP_PLAIN: case CXt_GIVEN: case CXt_WHEN: - gotoprobe = OP_SIBLING(cx->blk_oldcop); + gotoprobe = OpSIBLING(cx->blk_oldcop); break; case CXt_SUBST: continue; case CXt_BLOCK: if (ix) { - gotoprobe = OP_SIBLING(cx->blk_oldcop); + gotoprobe = OpSIBLING(cx->blk_oldcop); in_block = TRUE; } else gotoprobe = PL_main_root; @@ -3051,9 +2965,9 @@ PP(pp_goto) enterops, enterops + GOTO_DEPTH); if (retop) break; - if ( (sibl1 = OP_SIBLING(gotoprobe)) && + if ( (sibl1 = OpSIBLING(gotoprobe)) && sibl1->op_type == OP_UNSTACK && - (sibl2 = OP_SIBLING(sibl1))) + (sibl2 = OpSIBLING(sibl1))) { retop = dofindlabel(sibl2, label, label_len, label_flags, enterops, @@ -3115,8 +3029,7 @@ PP(pp_goto) } } - else { - assert(do_dump); + if (do_dump) { #ifdef VMS if (!retop) retop = PL_main_start; #endif @@ -3237,7 +3150,7 @@ S_docatch(pTHX_ OP *o) JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; @@ -3297,7 +3210,7 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) switch (cond) { case FIND_RUNCV_padid_eq: if (!CvPADLIST(cv) - || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg)) + || CvPADLIST(cv)->xpadl_id != (U32)arg) continue; return cv; case FIND_RUNCV_level_eq: @@ -3335,7 +3248,7 @@ S_try_yyparse(pTHX_ int gramtype) default: JMPENV_POP; JMPENV_JUMP(ret); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ } JMPENV_POP; return ret; @@ -3576,6 +3489,7 @@ S_check_type_and_open(pTHX_ SV *name) { Stat_t st; STRLEN len; + PerlIO * retio; const char *p = SvPV_const(name, len); int st_rc; @@ -3590,6 +3504,11 @@ S_check_type_and_open(pTHX_ SV *name) if (!IS_SAFE_PATHNAME(p, len, "require")) return NULL; + /* on Win32 stat is expensive (it does an open() and close() twice and + a couple other IO calls), the open will fail with a dir on its own with + errno EACCES, so only do a stat to separate a dir from a real EACCES + caused by user perms */ +#ifndef WIN32 /* we use the value of errno later to see how stat() or open() failed. * We don't want it set if the stat succeeded but we still failed, * such as if the name exists, but is a directory */ @@ -3600,12 +3519,29 @@ S_check_type_and_open(pTHX_ SV *name) if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } +#endif #if !defined(PERLIO_IS_STDIO) - return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); + retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name); #else - return PerlIO_open(p, PERL_SCRIPT_MODE); + retio = PerlIO_open(p, PERL_SCRIPT_MODE); #endif +#ifdef WIN32 + /* EACCES stops the INC search early in pp_require to implement + feature RT #113422 */ + if(!retio && errno == EACCES) { /* exists but probably a directory */ + int eno; + st_rc = PerlLIO_stat(p, &st); + if (st_rc >= 0) { + if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) + eno = 0; + else + eno = EACCES; + errno = eno; + } + } +#endif + return retio; } #ifndef PERL_DISABLE_PMC @@ -3641,7 +3577,7 @@ S_doopen_pm(pTHX_ SV *name) #endif /* !PERL_DISABLE_PMC */ /* require doesn't search for absolute names, or when the name is - explicity relative the current directory */ + explicitly relative the current directory */ PERL_STATIC_INLINE bool S_path_is_searchable(const char *name) { @@ -3691,7 +3627,6 @@ PP(pp_require) SV *filter_state = NULL; SV *filter_sub = NULL; SV *hook_sv = NULL; - SV *encoding; OP *op; int saved_errno; bool path_searchable; @@ -4049,7 +3984,8 @@ PP(pp_require) if (PL_op->op_type == OP_REQUIRE) { if(saved_errno == EMFILE || saved_errno == EACCES) { /* diag_listed_as: Can't locate %s */ - DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno)); + DIE(aTHX_ "Can't locate %s: %s: %s", + name, tryname, Strerror(saved_errno)); } else { if (namesv) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); @@ -4138,18 +4074,11 @@ PP(pp_require) PUTBACK; - /* Store and reset encoding. */ - encoding = PL_encoding; - PL_encoding = NULL; - if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL)) op = DOCATCH(PL_eval_start); else op = PL_op->op_next; - /* Restore encoding. */ - PL_encoding = encoding; - LOADED_FILE_PROBE(unixname); return op; @@ -4303,10 +4232,11 @@ PP(pp_leaveeval) I32 gimme; PERL_CONTEXT *cx; OP *retop; - const U8 save_flags = PL_op -> op_flags; I32 optype; SV *namesv; CV *evalcv; + /* grab this value before POPEVAL restores old PL_in_eval */ + bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); PERL_ASYNC_CHECK(); POPBLOCK(cx,newpm); @@ -4338,9 +4268,8 @@ PP(pp_leaveeval) } else { LEAVE_with_name("eval"); - if (!(save_flags & OPf_SPECIAL)) { + if (!keep) CLEAR_ERRSV(); - } } RETURNOP(retop); @@ -4406,9 +4335,11 @@ PP(pp_leavetry) I32 gimme; PERL_CONTEXT *cx; I32 optype; + OP *retop; PERL_ASYNC_CHECK(); POPBLOCK(cx,newpm); + retop = cx->blk_eval.retop; POPEVAL(cx); PERL_UNUSED_VAR(optype); @@ -4418,7 +4349,7 @@ PP(pp_leavetry) LEAVE_with_name("eval_scope"); CLEAR_ERRSV(); - RETURN; + RETURNOP(retop); } PP(pp_entergiven) @@ -4486,6 +4417,7 @@ STATIC bool S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dSP; + bool result; PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; @@ -4494,7 +4426,10 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) PUTBACK; (void) Perl_pp_match(aTHX); SPAGAIN; - return (SvTRUEx(POPs)); + result = SvTRUEx(POPs); + PUTBACK; + + return result; } STATIC void @@ -4556,7 +4491,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } SP -= 2; /* Pop the values */ - + PUTBACK; /* ~~ undef */ if (!SvOK(e)) { @@ -4567,11 +4502,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) RETPUSHYES; } - if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { + if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); } - if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) + if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) object_on_left = TRUE; /* ~~ sub */ @@ -4753,11 +4688,14 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) (void) hv_iterinit(hv); while ( (he = hv_iternext(hv)) ) { DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); + PUTBACK; if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { + SPAGAIN; (void) hv_iterinit(hv); destroy_matcher(matcher); RETPUSHYES; } + SPAGAIN; } destroy_matcher(matcher); RETPUSHNO; @@ -4862,10 +4800,13 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) for(i = 0; i <= this_len; ++i) { SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); + PUTBACK; if (svp && matcher_matches_sv(matcher, *svp)) { + SPAGAIN; destroy_matcher(matcher); RETPUSHYES; } + SPAGAIN; } destroy_matcher(matcher); RETPUSHNO; @@ -4926,12 +4867,13 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } else { PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); + bool result; DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); PUTBACK; - PUSHs(matcher_matches_sv(matcher, d) - ? &PL_sv_yes - : &PL_sv_no); + result = matcher_matches_sv(matcher, d); + SPAGAIN; + PUSHs(result ? &PL_sv_yes : &PL_sv_no); destroy_matcher(matcher); RETURN; } @@ -5411,7 +5353,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) umaxlen = maxlen; /* I was having segfault trouble under Linux 2.2.5 after a - parse error occured. (Had to hack around it with a test + parse error occurred. (Had to hack around it with a test for PL_parser->error_count == 0.) Solaris doesn't segfault -- not sure where the trouble is yet. XXX */ @@ -5588,11 +5530,5 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */