X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d0279c7ce493b7237b2f252043db1926615bc800..98e1e01b60e129ae5505bba4a6c3312783b48d20:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index b2ab8a5..1fc855d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -69,9 +69,6 @@ PP(pp_wantarray) PP(pp_regcreset) { dVAR; - /* XXXX Should store the old value to allow for tie/overload - and - restore in regcomp, where marked with XXXX. */ - PL_reginterp_cnt = 0; TAINT_NOT; return NORMAL; } @@ -80,199 +77,113 @@ PP(pp_regcomp) { dVAR; dSP; - register PMOP *pm = (PMOP*)cLOGOP->op_other; - SV *tmpstr; + PMOP *pm = (PMOP*)cLOGOP->op_other; + SV **args; + int nargs; REGEXP *re = NULL; + REGEXP *new_re; + const regexp_engine *eng; + bool is_bare_re; + + if (PL_op->op_flags & OPf_STACKED) { + dMARK; + nargs = SP - MARK; + args = ++MARK; + } + else { + nargs = 1; + args = SP; + } /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { - if (PL_op->op_flags & OPf_STACKED) { - dMARK; - SP = MARK; - } - else - (void)POPs; + SP = args-1; RETURN; } #endif -#define tryAMAGICregexp(rx) \ - STMT_START { \ - SvGETMAGIC(rx); \ - if (SvROK(rx) && SvAMAGIC(rx)) { \ - SV *sv = AMG_CALLunary(rx, regexp_amg); \ - if (sv) { \ - if (SvROK(sv)) \ - sv = SvRV(sv); \ - if (SvTYPE(sv) != SVt_REGEXP) \ - Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \ - rx = sv; \ - } \ - } \ - } STMT_END - - - if (PL_op->op_flags & OPf_STACKED) { - /* multiple args; concatenate them */ - dMARK; dORIGMARK; - tmpstr = PAD_SV(ARGTARG); - sv_setpvs(tmpstr, ""); - while (++MARK <= SP) { - SV *msv = *MARK; - SV *sv; - - tryAMAGICregexp(msv); - - if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) && - (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign))) - { - sv_setsv(tmpstr, sv); - continue; - } - - if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP) { - msv = SvRV(msv); - PL_reginterp_cnt += - RX_SEEN_EVALS((REGEXP *)MUTABLE_PTR(msv)); - } - - sv_catsv_nomg(tmpstr, msv); + re = PM_GETRE(pm); + assert (re != (REGEXP*) &PL_sv_undef); + eng = re ? RX_ENGINE(re) : current_re_engine(); + + new_re = (eng->op_comp + ? eng->op_comp + : &Perl_re_op_compile + )(aTHX_ args, nargs, pm->op_code_list, eng, re, + &is_bare_re, + (pm->op_pmflags & RXf_PMf_COMPILETIME), + pm->op_pmflags | + (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); + if (pm->op_pmflags & PMf_HAS_CV) + ((struct regexp *)SvANY(new_re))->qr_anoncv + = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); + + if (is_bare_re) { + REGEXP *tmp; + /* The match's LHS's get-magic might need to access this op's regexp + (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call + get-magic now before we replace the regexp. Hopefully this hack can + be replaced with the approach described at + http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html + some day. */ + if (pm->op_type == OP_MATCH) { + SV *lhs; + const bool was_tainted = PL_tainted; + if (pm->op_flags & OPf_STACKED) + lhs = args[-1]; + else if (pm->op_private & OPpTARGET_MY) + lhs = PAD_SV(pm->op_targ); + else lhs = DEFSV; + SvGETMAGIC(lhs); + /* Restore the previous value of PL_tainted (which may have been + modified by get-magic), to avoid incorrectly setting the + RXf_TAINTED flag further down. */ + PL_tainted = was_tainted; } - SvSETMAGIC(tmpstr); - SP = ORIGMARK; + tmp = reg_temp_copy(NULL, new_re); + ReREFCNT_dec(new_re); + new_re = tmp; } - else { - tmpstr = POPs; - tryAMAGICregexp(tmpstr); - } - -#undef tryAMAGICregexp - - if (SvROK(tmpstr)) { - SV * const sv = SvRV(tmpstr); - if (SvTYPE(sv) == SVt_REGEXP) - re = (REGEXP*) sv; - } - else if (SvTYPE(tmpstr) == SVt_REGEXP) - re = (REGEXP*) tmpstr; - - if (re) { - /* The match's LHS's get-magic might need to access this op's reg- - exp (as is sometimes the case with $'; see bug 70764). So we - must call get-magic now before we replace the regexp. Hopeful- - ly this hack can be replaced with the approach described at - http://www.nntp.perl.org/group/perl.perl5.porters/2007/03 - /msg122415.html some day. */ - if(pm->op_type == OP_MATCH) { - SV *lhs; - const bool was_tainted = PL_tainted; - if (pm->op_flags & OPf_STACKED) - lhs = TOPs; - else if (pm->op_private & OPpTARGET_MY) - lhs = PAD_SV(pm->op_targ); - else lhs = DEFSV; - SvGETMAGIC(lhs); - /* Restore the previous value of PL_tainted (which may have been - modified by get-magic), to avoid incorrectly setting the - RXf_TAINTED flag further down. */ - PL_tainted = was_tainted; - } - - re = reg_temp_copy(NULL, re); - ReREFCNT_dec(PM_GETRE(pm)); - PM_SETRE(pm, re); + if (re != new_re) { + ReREFCNT_dec(re); + PM_SETRE(pm, new_re); } - else { - STRLEN len = 0; - const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : ""; - - re = PM_GETRE(pm); - assert (re != (REGEXP*) &PL_sv_undef); - - /* Check against the last compiled regexp. */ - if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len || - memNE(RX_PRECOMP(re), t, len)) - { - const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; - U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; - if (re) { - ReREFCNT_dec(re); -#ifdef USE_ITHREADS - PM_SETRE(pm, (REGEXP*) &PL_sv_undef); -#else - PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ -#endif - } else if (PL_curcop->cop_hints_hash) { - SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0); - if (ptr && SvIOK(ptr) && SvIV(ptr)) - eng = INT2PTR(regexp_engine*,SvIV(ptr)); - } - - if (PL_op->op_flags & OPf_SPECIAL) - PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ - - if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) { - /* Not doing UTF-8, despite what the SV says. Is this only if - we're trapped in use 'bytes'? */ - /* Make a copy of the octet sequence, but without the flag on, - as the compiler now honours the SvUTF8 flag on tmpstr. */ - STRLEN len; - const char *const p = SvPV(tmpstr, len); - tmpstr = newSVpvn_flags(p, len, SVs_TEMP); - } - else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) { - /* make a copy to avoid extra stringifies */ - tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr)); - } - - if (eng) - PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); - else - PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); - - PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed - inside tie/overload accessors. */ - } - } - - re = PM_GETRE(pm); #ifndef INCOMPLETE_TAINTS - if (PL_tainting) { - if (PL_tainted) { - SvTAINTED_on((SV*)re); - RX_EXTFLAGS(re) |= RXf_TAINTED; - } + if (PL_tainting && PL_tainted) { + SvTAINTED_on((SV*)new_re); + RX_EXTFLAGS(new_re) |= RXf_TAINTED; } #endif - if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) - pm = PL_curpm; - - #if !defined(USE_ITHREADS) /* can't change the optree at runtime either */ /* PMf_KEEP is handled differently under threads to avoid these problems */ + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) + pm = PL_curpm; if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ cLOGOP->op_first->op_next = PL_op->op_next; } #endif + + SP = args-1; RETURN; } + PP(pp_substcont) { dVAR; dSP; - register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - register PMOP * const pm = (PMOP*) cLOGOP->op_other; - register SV * const dstr = cx->sb_dstr; - register char *s = cx->sb_s; - register char *m = cx->sb_m; + PERL_CONTEXT *cx = &cxstack[cxstack_ix]; + PMOP * const pm = (PMOP*) cLOGOP->op_other; + SV * const dstr = cx->sb_dstr; + char *s = cx->sb_s; + char *m = cx->sb_m; char *orig = cx->sb_orig; - register REGEXP * const rx = cx->sb_rx; + REGEXP * const rx = cx->sb_rx; SV *nsv = NULL; REGEXP *old = PM_GETRE(pm); @@ -305,18 +216,16 @@ PP(pp_substcont) if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, (s == m) + RX_GOFS(rx), cx->sb_targ, NULL, - ((cx->sb_rflags & REXEC_COPY_STR) - ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) - : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) + (REXEC_IGNOREPOS|REXEC_NOT_FIRST))) { SV *targ = cx->sb_targ; assert(cx->sb_strend >= s); if(cx->sb_strend > s) { if (DO_UTF8(dstr) && !SvUTF8(targ)) - sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); + sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); else - sv_catpvn(dstr, s, cx->sb_strend - s); + sv_catpvn_nomg(dstr, s, cx->sb_strend - s); } if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ cx->sb_rxtainted |= SUBST_TAINT_PAT; @@ -371,13 +280,14 @@ PP(pp_substcont) LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } cx->sb_iters = saviters; } if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; + assert(!RX_SUBOFFSET(rx)); cx->sb_orig = orig = RX_SUBBEG(rx); s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); @@ -385,9 +295,9 @@ PP(pp_substcont) cx->sb_m = m = RX_OFFS(rx)[0].start + orig; if (m > s) { if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) - sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); + sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv); else - sv_catpvn(dstr, s, m-s); + sv_catpvn_nomg(dstr, s, m-s); } cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ @@ -442,9 +352,9 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) if (!p || p[1] < RX_NPARENS(rx)) { #ifdef PERL_OLD_COPY_ON_WRITE - i = 7 + RX_NPARENS(rx) * 2; + i = 7 + (RX_NPARENS(rx)+1) * 2; #else - i = 6 + RX_NPARENS(rx) * 2; + i = 6 + (RX_NPARENS(rx)+1) * 2; #endif if (!p) Newx(p, i, UV); @@ -453,6 +363,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *rsp = (void*)p; } + /* what (if anything) to free on croak */ *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); RX_MATCH_COPIED_off(rx); @@ -462,9 +373,10 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) #endif *p++ = RX_NPARENS(rx); - *p++ = PTR2UV(RX_SUBBEG(rx)); *p++ = (UV)RX_SUBLEN(rx); + *p++ = (UV)RX_SUBOFFSET(rx); + *p++ = (UV)RX_SUBCOFFSET(rx); for (i = 0; i <= RX_NPARENS(rx); ++i) { *p++ = (UV)RX_OFFS(rx)[i].start; *p++ = (UV)RX_OFFS(rx)[i].end; @@ -492,9 +404,10 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) #endif RX_NPARENS(rx) = *p++; - RX_SUBBEG(rx) = INT2PTR(char*,*p++); RX_SUBLEN(rx) = (I32)(*p++); + RX_SUBOFFSET(rx) = (I32)*p++; + RX_SUBCOFFSET(rx) = (I32)*p++; for (i = 0; i <= RX_NPARENS(rx); ++i) { RX_OFFS(rx)[i].start = (I32)(*p++); RX_OFFS(rx)[i].end = (I32)(*p++); @@ -534,13 +447,13 @@ S_rxres_free(pTHX_ void **rsp) PP(pp_formline) { dVAR; dSP; dMARK; dORIGMARK; - register SV * const tmpForm = *++MARK; + SV * const tmpForm = *++MARK; SV *formsv; /* contains text of original format */ - register U32 *fpc; /* format ops program counter */ - register char *t; /* current append position in target string */ + U32 *fpc; /* format ops program counter */ + char *t; /* current append position in target string */ const char *f; /* current position in format string */ - register I32 arg; - register SV *sv = NULL; /* current item */ + I32 arg; + SV *sv = NULL; /* current item */ const char *item = NULL;/* string value of current item */ I32 itemsize = 0; /* length of current item, possibly truncated */ I32 fieldsize = 0; /* width of current field */ @@ -1298,7 +1211,7 @@ PP(pp_flop) SvGETMAGIC(right); if (RANGE_IS_NUMERIC(left,right)) { - register IV i, j; + IV i, j; IV max; if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) || (SvOK(right) && SvNV_nomg(right) > IV_MAX)) @@ -1382,12 +1295,12 @@ STATIC I32 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) { dVAR; - register I32 i; + I32 i; PERL_ARGS_ASSERT_DOPOPTOLABEL; for (i = cxstack_ix; i >= 0; i--) { - register const PERL_CONTEXT * const cx = &cxstack[i]; + const PERL_CONTEXT * const cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: @@ -1458,7 +1371,7 @@ Perl_block_gimme(pTHX) return G_ARRAY; default: Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ return 0; } } @@ -1499,7 +1412,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) PERL_ARGS_ASSERT_DOPOPTOSUB_AT; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT * const cx = &cxstk[i]; + const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; @@ -1519,7 +1432,7 @@ S_dopoptoeval(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT *cx = &cxstack[i]; + const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; @@ -1537,7 +1450,7 @@ S_dopoptoloop(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT * const cx = &cxstack[i]; + const PERL_CONTEXT * const cx = &cxstack[i]; switch (CxTYPE(cx)) { case CXt_SUBST: case CXt_SUB: @@ -1567,7 +1480,7 @@ S_dopoptogiven(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT *cx = &cxstack[i]; + const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; @@ -1595,7 +1508,7 @@ S_dopoptowhen(pTHX_ I32 startingblock) dVAR; I32 i; for (i = startingblock; i >= 0; i--) { - register const PERL_CONTEXT *cx = &cxstack[i]; + const PERL_CONTEXT *cx = &cxstack[i]; switch (CxTYPE(cx)) { default: continue; @@ -1618,7 +1531,7 @@ Perl_dounwind(pTHX_ I32 cxix) while (cxstack_ix > cxix) { SV *sv; - register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; + PERL_CONTEXT *cx = &cxstack[cxstack_ix]; DEBUG_CX("UNWIND"); \ /* Note: we don't need to restore the base context info till the end. */ switch (CxTYPE(cx)) { @@ -1728,7 +1641,7 @@ Perl_die_unwind(pTHX_ SV *msv) if (cxix >= 0) { I32 optype; SV *namesv; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV **newsp; COP *oldcop; JMPENV *restartjmpenv; @@ -1786,13 +1699,13 @@ Perl_die_unwind(pTHX_ SV *msv) PL_restartjmpenv = restartjmpenv; PL_restartop = restartop; JMPENV_JUMP(3); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } } write_to_stderr(exceptsv); my_failure_exit(); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } PP(pp_xor) @@ -1826,9 +1739,9 @@ frame for the sub call itself. const PERL_CONTEXT * Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { - register I32 cxix = dopoptosub(cxstack_ix); - register const PERL_CONTEXT *cx; - register const PERL_CONTEXT *ccstack = cxstack; + I32 cxix = dopoptosub(cxstack_ix); + const PERL_CONTEXT *cx; + const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; for (;;) { @@ -1868,7 +1781,7 @@ PP(pp_caller) { dVAR; dSP; - register const PERL_CONTEXT *cx; + const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; I32 gimme; const HEK *stash_hek; @@ -1892,7 +1805,9 @@ PP(pp_caller) DEBUG_CX("CALLER"); assert(CopSTASH(cx->blk_oldcop)); - stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)); + stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV + ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)) + : NULL; if (GIMME != G_ARRAY) { EXTEND(SP, 1); if (!stash_hek) @@ -1921,7 +1836,7 @@ PP(pp_caller) if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { GV * const cvgv = CvGV(dbcx->blk_sub.cv); /* So is ccstack[dbcxix]. */ - if (isGV(cvgv)) { + if (cvgv && isGV(cvgv)) { SV * const sv = newSV(0); gv_efullname3(sv, cvgv, NULL); mPUSHs(sv); @@ -1944,7 +1859,9 @@ PP(pp_caller) if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { - PUSHs(cx->blk_eval.cur_text); + PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), + SvCUR(cx->blk_eval.cur_text)-2, + SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); PUSHs(&PL_sv_no); } /* require */ @@ -2037,11 +1954,11 @@ PP(pp_dbstate) || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = G_ARRAY; U8 hasargs; GV * const gv = PL_DBgv; - register CV * const cv = GvCV(gv); + CV * const cv = GvCV(gv); if (!cv) DIE(aTHX_ "No DB::DB routine defined"); @@ -2060,10 +1977,8 @@ PP(pp_dbstate) SPAGAIN; if (CvISXSUB(cv)) { - CvDEPTH(cv)++; PUSHMARK(SP); (void)(*CvXSUB(cv))(aTHX_ cv); - CvDEPTH(cv)--; FREETMPS; LEAVE; return NORMAL; @@ -2124,7 +2039,7 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 fla PP(pp_enter) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER_with_name("block"); @@ -2138,7 +2053,7 @@ PP(pp_enter) PP(pp_leave) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV **newsp; PMOP *newpm; I32 gimme; @@ -2164,7 +2079,7 @@ PP(pp_leave) PP(pp_enteriter) { dVAR; dSP; dMARK; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; void *itervar; /* location of the iteration variable */ U8 cxtype = CXt_LOOP_FOR; @@ -2287,7 +2202,7 @@ PP(pp_enteriter) PP(pp_enterloop) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; ENTER_with_name("loop1"); @@ -2303,7 +2218,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -2440,7 +2355,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, PP(pp_return) { dVAR; dSP; dMARK; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; bool lval = FALSE; @@ -2584,7 +2499,7 @@ PP(pp_leavesublv) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *sv; if (CxMULTICALL(&cxstack[cxstack_ix])) @@ -2606,38 +2521,60 @@ PP(pp_leavesublv) return cx->blk_sub.retop; } -PP(pp_last) +static I32 +S_unwind_loop(pTHX_ const char * const opname) { - dVAR; dSP; + dVAR; I32 cxix; - register PERL_CONTEXT *cx; - I32 pop2 = 0; - I32 gimme; - I32 optype; - OP *nextop = NULL; - SV **newsp; - PMOP *newpm; - SV **mark; - SV *sv = NULL; - - if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"last\" outside a loop block"); + /* diag_listed_as: Can't "last" outside a loop block */ + Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname); } else { - cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv), - (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0); + dSP; + STRLEN label_len; + const char * const label = + PL_op->op_flags & OPf_STACKED + ? SvPV(TOPs,label_len) + : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv); + const U32 label_flags = + PL_op->op_flags & OPf_STACKED + ? SvUTF8(POPs) + : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; + PUTBACK; + cxix = dopoptolabel(label, label_len, label_flags); if (cxix < 0) - DIE(aTHX_ "Label not found for \"last %"SVf"\"", - SVfARG(newSVpvn_flags(cPVOP->op_pv, - strlen(cPVOP->op_pv), - ((cPVOP->op_private & OPpPV_IS_UTF8) - ? SVf_UTF8 : 0) | SVs_TEMP))); + /* diag_listed_as: Label not found for "last %s" */ + Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", + opname, + SVfARG(PL_op->op_flags & OPf_STACKED + && !SvGMAGICAL(TOPp1s) + ? TOPp1s + : newSVpvn_flags(label, + label_len, + label_flags | SVs_TEMP))); } if (cxix < cxstack_ix) dounwind(cxix); + return cxix; +} + +PP(pp_last) +{ + dVAR; + PERL_CONTEXT *cx; + I32 pop2 = 0; + I32 gimme; + I32 optype; + OP *nextop = NULL; + SV **newsp; + PMOP *newpm; + SV **mark; + SV *sv = NULL; + + S_unwind_loop(aTHX_ "last"); POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2668,9 +2605,8 @@ PP(pp_last) } TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, + PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme, pop2 == CXt_SUB ? SVs_TEMP : 0); - PUTBACK; LEAVE; cxstack_ix--; @@ -2698,31 +2634,13 @@ PP(pp_last) PP(pp_next) { dVAR; - I32 cxix; - register PERL_CONTEXT *cx; - I32 inner; + PERL_CONTEXT *cx; + const I32 inner = PL_scopestack_ix; - if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't \"next\" outside a loop block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv), - (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0); - if (cxix < 0) - DIE(aTHX_ "Label not found for \"next %"SVf"\"", - SVfARG(newSVpvn_flags(cPVOP->op_pv, - strlen(cPVOP->op_pv), - ((cPVOP->op_private & OPpPV_IS_UTF8) - ? SVf_UTF8 : 0) | SVs_TEMP))); - } - if (cxix < cxstack_ix) - dounwind(cxix); + S_unwind_loop(aTHX_ "next"); /* clear off anything above the scope we're re-entering, but * save the rest until after a possible continue block */ - inner = PL_scopestack_ix; TOPBLOCK(cx); if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); @@ -2733,30 +2651,11 @@ PP(pp_next) PP(pp_redo) { dVAR; - I32 cxix; - register PERL_CONTEXT *cx; + const I32 cxix = S_unwind_loop(aTHX_ "redo"); + PERL_CONTEXT *cx; I32 oldsave; - OP* redo_op; + OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; - if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't \"redo\" outside a loop block"); - } - else { - cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv), - (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0); - if (cxix < 0) - DIE(aTHX_ "Label not found for \"redo %"SVf"\"", - SVfARG(newSVpvn_flags(cPVOP->op_pv, - strlen(cPVOP->op_pv), - ((cPVOP->op_private & OPpPV_IS_UTF8) - ? SVf_UTF8 : 0) | SVs_TEMP))); - } - if (cxix < cxstack_ix) - dounwind(cxix); - - redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ cxstack_ix++; @@ -2842,7 +2741,7 @@ PP(pp_goto) dVAR; dSP; OP *retop = NULL; I32 ix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; const char *label = NULL; @@ -2857,7 +2756,7 @@ PP(pp_goto) /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; CV *cv = MUTABLE_CV(SvRV(sv)); SV** mark; I32 items = 0; @@ -2976,7 +2875,7 @@ PP(pp_goto) return retop; } else { - AV* const padlist = CvPADLIST(cv); + PADLIST * const padlist = CvPADLIST(cv); if (CxTYPE(cx) == CXt_EVAL) { PL_in_eval = CxOLD_IN_EVAL(cx); PL_eval_root = cx->blk_eval.old_eval_root; @@ -3309,149 +3208,13 @@ S_docatch(pTHX_ OP *o) JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; return NULL; } -/* James Bond: Do you expect me to talk? - Auric Goldfinger: No, Mr. Bond. I expect you to die. - - This code is an ugly hack, doesn't work with lexicals in subroutines that are - called more than once, and is only used by regcomp.c, for (?{}) blocks. - - Currently it is not used outside the core code. Best if it stays that way. - - Hence it's now deprecated, and will be removed. -*/ -OP * -Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) -/* sv Text to convert to OP tree. */ -/* startop op_free() this to undo. */ -/* code Short string id of the caller. */ -{ - PERL_ARGS_ASSERT_SV_COMPILE_2OP; - return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp); -} - -/* Don't use this. It will go away without warning once the regexp engine is - refactored not to use it. */ -OP * -Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code, - PAD **padp) -{ - dVAR; dSP; /* Make POPBLOCK work. */ - PERL_CONTEXT *cx; - SV **newsp; - I32 gimme = G_VOID; - I32 optype; - OP dummy; - char tbuf[TYPE_DIGITS(long) + 12 + 10]; - char *tmpbuf = tbuf; - char *safestr; - int runtime; - CV* runcv = NULL; /* initialise to avoid compiler warnings */ - STRLEN len; - bool need_catch; - - PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN; - - ENTER_with_name("eval"); - lex_start(sv, NULL, LEX_START_SAME_FILTER); - SAVETMPS; - /* switch to eval mode */ - - if (IN_PERL_COMPILETIME) { - SAVECOPSTASH_FREE(&PL_compiling); - CopSTASH_set(&PL_compiling, PL_curstash); - } - if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { - SV * const sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", - code, (unsigned long)++PL_evalseq, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - tmpbuf = SvPVX(sv); - len = SvCUR(sv); - } - else - len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code, - (unsigned long)++PL_evalseq); - SAVECOPFILE_FREE(&PL_compiling); - CopFILE_set(&PL_compiling, tmpbuf+2); - SAVECOPLINE(&PL_compiling); - CopLINE_set(&PL_compiling, 1); - /* XXX For Cs within BEGIN {} blocks, this ends up - deleting the eval's FILEGV from the stash before gv_check() runs - (i.e. before run-time proper). To work around the coredump that - ensues, we always turn GvMULTI_on for any globals that were - introduced within evals. See force_ident(). GSAR 96-10-12 */ - safestr = savepvn(tmpbuf, len); - SAVEDELETE(PL_defstash, safestr, len); - SAVEHINTS(); -#ifdef OP_IN_REGISTER - PL_opsave = op; -#else - SAVEVPTR(PL_op); -#endif - - /* we get here either during compilation, or via pp_regcomp at runtime */ - runtime = IN_PERL_RUNTIME; - if (runtime) - { - runcv = find_runcv(NULL); - - /* At run time, we have to fetch the hints from PL_curcop. */ - PL_hints = PL_curcop->cop_hints; - if (PL_hints & HINT_LOCALIZE_HH) { - /* SAVEHINTS created a new HV in PL_hintgv, which we - need to GC */ - SvREFCNT_dec(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = - refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0); - hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints); - } - SAVECOMPILEWARNINGS(); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - cophh_free(CopHINTHASH_get(&PL_compiling)); - /* XXX Does this need to avoid copying a label? */ - PL_compiling.cop_hints_hash - = cophh_copy(PL_curcop->cop_hints_hash); - } - - PL_op = &dummy; - PL_op->op_type = OP_ENTEREVAL; - PL_op->op_flags = 0; /* Avoid uninit warning. */ - PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); - PUSHEVAL(cx, 0); - need_catch = CATCH_GET; - CATCH_SET(TRUE); - - if (runtime) - (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL); - else - (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL); - CATCH_SET(need_catch); - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); - - (*startop)->op_type = OP_NULL; - (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; - /* XXX DAPM do this properly one year */ - *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); - LEAVE_with_name("eval"); - if (IN_PERL_COMPILETIME) - CopHINTS_set(&PL_compiling, PL_hints); -#ifdef OP_IN_REGISTER - op = PL_opsave; -#endif - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(optype); - - return PL_eval_start; -} - /* =for apidoc find_runcv @@ -3468,8 +3231,16 @@ than in the scope of the debugger itself). CV* Perl_find_runcv(pTHX_ U32 *db_seqp) { + return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp); +} + +/* If this becomes part of the API, it might need a better name. */ +CV * +Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) +{ dVAR; PERL_SI *si; + int level = 0; if (db_seqp) *db_seqp = PL_curcop->cop_seq; @@ -3477,20 +3248,33 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) I32 ix; for (ix = si->si_cxix; ix >= 0; ix--) { const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); + CV *cv = NULL; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - CV * const cv = cx->blk_sub.cv; + cv = cx->blk_sub.cv; /* skip DB:: code */ if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { *db_seqp = cx->blk_oldcop->cop_seq; continue; } - return cv; } else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) - return cx->blk_eval.cv; + cv = cx->blk_eval.cv; + if (cv) { + switch (cond) { + case FIND_RUNCV_padid_eq: + if (!CvPADLIST(cv) + || CvPADLIST(cv)->xpadl_id != (U32)arg) continue; + return cv; + case FIND_RUNCV_level_eq: + if (level++ != arg) continue; + /* GERONIMO! */ + default: + return cv; + } + } } } - return PL_main_cv; + return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; } @@ -3516,36 +3300,35 @@ S_try_yyparse(pTHX_ int gramtype) default: JMPENV_POP; JMPENV_JUMP(ret); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } JMPENV_POP; return ret; } -/* Compile a require/do, an eval '', or a /(?{...})/. - * In the last case, startop is non-null, and contains the address of - * a pointer that should be set to the just-compiled code. +/* Compile a require/do or an eval ''. + * * outside is the lexically enclosing CV (if any) that invoked us. + * seq is the current COP scope value. + * hh is the saved hints hash, if any. + * * Returns a bool indicating whether the compile was successful; if so, - * PL_eval_start contains the first op of the compiled ocde; otherwise, - * pushes undef (also croaks if startop != NULL). - */ - -/* This function is called from three places, sv_compile_2op, pp_require - * and pp_entereval. These can be distinguished as follows: - * sv_compile_2op - startop is non-null - * pp_require - startop is null; saveop is not entereval - * pp_entereval - startop is null; saveop is entereval + * PL_eval_start contains the first op of the compiled code; otherwise, + * pushes undef. + * + * This function is called from two places: pp_require and pp_entereval. + * These can be distinguished by whether PL_op is entereval. */ STATIC bool -S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) +S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) { dVAR; dSP; OP * const saveop = PL_op; + bool clear_hints = saveop->op_type != OP_ENTEREVAL; COP * const oldcurcop = PL_curcop; - bool in_require = (saveop && saveop->op_type == OP_REQUIRE); + bool in_require = (saveop->op_type == OP_REQUIRE); int yystatus; CV *evalcv; @@ -3592,7 +3375,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) PL_madskills = 0; #endif - if (!startop) ENTER_with_name("evalcomp"); + ENTER_with_name("evalcomp"); SAVESPTR(PL_compcv); PL_compcv = evalcv; @@ -3600,52 +3383,49 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) PL_eval_root = NULL; PL_curcop = &PL_compiling; - if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) + if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else CLEAR_ERRSV(); - if (!startop) { - bool clear_hints = saveop->op_type != OP_ENTEREVAL; - SAVEHINTS(); - if (clear_hints) { - PL_hints = 0; - hv_clear(GvHV(PL_hintgv)); - } - else { - PL_hints = saveop->op_private & OPpEVAL_COPHH - ? oldcurcop->cop_hints : saveop->op_targ; - if (hh) { - /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ - SvREFCNT_dec(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = hh; - } - } - SAVECOMPILEWARNINGS(); - if (clear_hints) { - if (PL_dowarn & G_WARN_ALL_ON) - PL_compiling.cop_warnings = pWARN_ALL ; - else if (PL_dowarn & G_WARN_ALL_OFF) - PL_compiling.cop_warnings = pWARN_NONE ; - else - PL_compiling.cop_warnings = pWARN_STD ; + SAVEHINTS(); + if (clear_hints) { + PL_hints = 0; + hv_clear(GvHV(PL_hintgv)); + } + else { + PL_hints = saveop->op_private & OPpEVAL_COPHH + ? oldcurcop->cop_hints : saveop->op_targ; + if (hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = hh; } - else { - PL_compiling.cop_warnings = - DUP_WARNINGS(oldcurcop->cop_warnings); - cophh_free(CopHINTHASH_get(&PL_compiling)); - if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { - /* The label, if present, is the first entry on the chain. So rather - than writing a blank label in front of it (which involves an - allocation), just use the next entry in the chain. */ - PL_compiling.cop_hints_hash - = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); - /* Check the assumption that this removed the label. */ - assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); - } - else - PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); + } + SAVECOMPILEWARNINGS(); + if (clear_hints) { + if (PL_dowarn & G_WARN_ALL_ON) + PL_compiling.cop_warnings = pWARN_ALL ; + else if (PL_dowarn & G_WARN_ALL_OFF) + PL_compiling.cop_warnings = pWARN_NONE ; + else + PL_compiling.cop_warnings = pWARN_STD ; + } + else { + PL_compiling.cop_warnings = + DUP_WARNINGS(oldcurcop->cop_warnings); + cophh_free(CopHINTHASH_get(&PL_compiling)); + if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { + /* The label, if present, is the first entry on the chain. So rather + than writing a blank label in front of it (which involves an + allocation), just use the next entry in the chain. */ + PL_compiling.cop_hints_hash + = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); + /* Check the assumption that this removed the label. */ + assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); } + else + PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); } CALL_BLOCK_HOOKS(bhk_eval, saveop); @@ -3671,15 +3451,14 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) PL_op = saveop; if (yystatus != 3) { if (PL_eval_root) { + cv_forget_slab(evalcv); op_free(PL_eval_root); PL_eval_root = NULL; } SP = PL_stack_base + POPMARK; /* pop original mark */ - if (!startop) { - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); - namesv = cx->blk_eval.old_namesv; - } + POPBLOCK(cx,PL_curpm); + POPEVAL(cx); + namesv = cx->blk_eval.old_namesv; /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */ LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ } @@ -3701,16 +3480,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) ? ERRSV : newSVpvs_flags("Unknown error\n", SVs_TEMP))); } - else if (startop) { - if (yystatus != 3) { - POPBLOCK(cx,PL_curpm); - POPEVAL(cx); - } - Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp", - SVfARG(ERRSV - ? ERRSV - : newSVpvs_flags("Unknown error\n", SVs_TEMP))); - } else { if (!*(SvPVx_nolen_const(ERRSV))) { sv_setpvs(ERRSV, "Compilation error"); @@ -3720,17 +3489,17 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh) PUTBACK; return FALSE; } - else if (!startop) LEAVE_with_name("evalcomp"); + else + LEAVE_with_name("evalcomp"); + CopLINE_set(&PL_compiling, 0); - if (startop) { - *startop = PL_eval_root; - } else - SAVEFREEOP(PL_eval_root); + SAVEFREEOP(PL_eval_root); + cv_forget_slab(evalcv); DEBUG_x(dump_eval()); /* Register with debugger: */ - if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { + if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; @@ -3806,7 +3575,7 @@ S_doopen_pm(pTHX_ SV *name) PP(pp_require) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *sv; const char *name; STRLEN len; @@ -3814,6 +3583,9 @@ PP(pp_require) STRLEN unixlen; #ifdef VMS int vms_unixname = 0; + char *unixnamebuf; + char *unixdir; + char *unixdirbuf; #endif const char *tryname = NULL; SV *namesv = NULL; @@ -3826,6 +3598,7 @@ PP(pp_require) SV *hook_sv = NULL; SV *encoding; OP *op; + int saved_errno; sv = POPs; if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { @@ -3898,7 +3671,9 @@ PP(pp_require) * To prevent this, the key must be stored in UNIX format if the VMS * name can be translated to UNIX. */ - if ((unixname = tounixspec(name, NULL)) != NULL) { + + if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) + && (unixname = tounixspec(name, unixnamebuf)) != NULL) { unixlen = strlen(unixname); vms_unixname = 1; } @@ -3923,6 +3698,8 @@ PP(pp_require) } } + LOADING_FILE_PROBE(unixname); + /* prepare to compile file */ if (path_is_absolute(name)) { @@ -3930,7 +3707,7 @@ PP(pp_require) tryname = name; tryrsfp = doopen_pm(sv); } - if (!tryrsfp) { + if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) { AV * const ar = GvAVn(PL_incgv); I32 i; #ifdef VMS @@ -4073,8 +3850,8 @@ PP(pp_require) } #ifdef VMS - char *unixdir; - if ((unixdir = tounixpath(dir, NULL)) == NULL) + if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL) + || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL)) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); @@ -4122,20 +3899,26 @@ PP(pp_require) } break; } - else if (errno == EMFILE) - /* no point in trying other paths if out of handles */ - break; + else if (errno == EMFILE || errno == EACCES) { + /* no point in trying other paths if out of handles; + * on the other hand, if we couldn't open one of the + * files, then going on with the search could lead to + * unexpected results; see perl #113422 + */ + break; + } } } } } } + saved_errno = errno; /* sv_2mortal can realloc things */ sv_2mortal(namesv); if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { - if(errno == EMFILE) { + if(saved_errno == EMFILE || saved_errno == EACCES) { /* diag_listed_as: Can't locate %s */ - DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno)); + DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno)); } else { if (namesv) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); @@ -4150,9 +3933,9 @@ PP(pp_require) DIE(aTHX_ "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")", name, - (memEQ(name + len - 2, ".h", 3) + (len >= 2 && memEQ(name + len - 2, ".h", 3) ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""), - (memEQ(name + len - 3, ".ph", 4) + (len >= 3 && memEQ(name + len - 3, ".ph", 4) ? " (did you run h2ph?)" : ""), inc ); @@ -4161,6 +3944,7 @@ PP(pp_require) DIE(aTHX_ "Can't locate %s", name); } + CLEAR_ERRSV(); RETPUSHUNDEF; } else @@ -4210,7 +3994,7 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = NULL; - if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL)) + if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL)) op = DOCATCH(PL_eval_start); else op = PL_op->op_next; @@ -4218,6 +4002,8 @@ PP(pp_require) /* Restore encoding. */ PL_encoding = encoding; + LOADED_FILE_PROBE(unixname); + return op; } @@ -4237,7 +4023,7 @@ PP(pp_hintseval) PP(pp_entereval) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *sv; const I32 gimme = GIMME_V; const U32 was = PL_breakable_sub_gen; @@ -4338,7 +4124,7 @@ PP(pp_entereval) PUTBACK; - if (doeval(gimme, NULL, runcv, seq, saved_hh)) { + if (doeval(gimme, runcv, seq, saved_hh)) { if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? (PERLDB_LINE || PERLDB_SAVESRC) : PERLDB_SAVESRC_NOSUBS) { @@ -4368,7 +4154,7 @@ PP(pp_leaveeval) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; OP *retop; const U8 save_flags = PL_op -> op_flags; I32 optype; @@ -4422,7 +4208,7 @@ Perl_delete_eval_scope(pTHX) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 optype; POPBLOCK(cx,newpm); @@ -4473,7 +4259,7 @@ PP(pp_leavetry) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 optype; PERL_ASYNC_CHECK(); @@ -4493,14 +4279,21 @@ PP(pp_leavetry) PP(pp_entergiven) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; ENTER_with_name("given"); SAVETMPS; - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); - sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs); + if (PL_op->op_targ) { + SAVEPADSVANDMORTALIZE(PL_op->op_targ); + SvREFCNT_dec(PAD_SVl(PL_op->op_targ)); + PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs); + } + else { + SAVE_DEFSV; + DEFSV_set(POPs); + } PUSHBLOCK(cx, CXt_GIVEN, SP); PUSHGIVEN(cx); @@ -4511,7 +4304,7 @@ PP(pp_entergiven) PP(pp_leavegiven) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -5059,7 +4852,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) PP(pp_enterwhen) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; const I32 gimme = GIMME_V; /* This is essentially an optimization: if the match @@ -5084,7 +4877,7 @@ PP(pp_leavewhen) { dVAR; dSP; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -5128,7 +4921,7 @@ PP(pp_continue) { dVAR; dSP; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -5156,7 +4949,7 @@ PP(pp_break) { dVAR; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; cxix = dopoptogiven(cxstack_ix); if (cxix < 0) @@ -5179,17 +4972,17 @@ static MAGIC * S_doparseform(pTHX_ SV *sv) { STRLEN len; - register char *s = SvPV(sv, len); - register char *send; - register char *base = NULL; /* start of current field */ - register I32 skipspaces = 0; /* number of contiguous spaces seen */ + char *s = SvPV(sv, len); + char *send; + char *base = NULL; /* start of current field */ + I32 skipspaces = 0; /* number of contiguous spaces seen */ bool noblank = FALSE; /* ~ or ~~ seen on this line */ bool repeat = FALSE; /* ~~ seen on this line */ bool postspace = FALSE; /* a text field may need right padding */ U32 *fops; - register U32 *fpc; + U32 *fpc; U32 *linepc = NULL; /* position of last FF_LINEMARK */ - register I32 arg; + I32 arg; bool ischop; /* it's a ^ rather than a @ */ bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */ int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ @@ -5469,6 +5262,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) char *prune_from = NULL; bool read_from_cache = FALSE; STRLEN umaxlen; + SV *err = NULL; PERL_ARGS_ASSERT_RUN_USER_FILTER; @@ -5547,7 +5341,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) PUSHs(filter_state); } PUTBACK; - count = call_sv(filter_sub, G_SCALAR); + count = call_sv(filter_sub, G_SCALAR|G_EVAL); SPAGAIN; if (count > 0) { @@ -5555,6 +5349,9 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (SvOK(out)) { status = SvIV(out); } + else if (SvTRUE(ERRSV)) { + err = newSVsv(ERRSV); + } } PUTBACK; @@ -5562,7 +5359,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) LEAVE_with_name("call_filter_sub"); } - if(SvOK(upstream)) { + if(!err && SvOK(upstream)) { got_p = SvPV(upstream, got_len); if (umaxlen) { if (got_len > umaxlen) { @@ -5576,7 +5373,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) } } } - if (prune_from) { + if (!err && prune_from) { /* Oh. Too long. Stuff some in our cache. */ STRLEN cached_len = got_p + got_len - prune_from; SV *const cache = datasv; @@ -5605,7 +5402,8 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) have touched the SV upstream, so it may be undefined. If we naively concatenate it then we get a warning about use of uninitialised value. */ - if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) { + if (!err && upstream != buf_sv && + (SvOK(upstream) || SvGMAGICAL(upstream))) { sv_catsv(buf_sv, upstream); } @@ -5621,6 +5419,10 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) } filter_del(S_run_user_filter); } + + if (err) + croak_sv(err); + if (status == 0 && read_from_cache) { /* If we read some data from the cache (and by getting here it implies that we emptied the cache) then we aren't yet at EOF, and mustn't