X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/76ac488f33062fb6944511be1ac932b9bbb66144..5eabab158821032728b40b21aab4353b1213e250:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 01bb5c3..1fc855d 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -77,7 +77,7 @@ PP(pp_regcomp) { dVAR; dSP; - register PMOP *pm = (PMOP*)cLOGOP->op_other; + PMOP *pm = (PMOP*)cLOGOP->op_other; SV **args; int nargs; REGEXP *re = NULL; @@ -177,13 +177,13 @@ 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); @@ -216,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; @@ -282,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); @@ -296,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. */ @@ -353,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); @@ -364,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); @@ -373,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; @@ -403,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++); @@ -445,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 */ @@ -1209,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)) @@ -1293,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: @@ -1369,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; } } @@ -1410,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; @@ -1430,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; @@ -1448,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: @@ -1478,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; @@ -1506,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; @@ -1529,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)) { @@ -1639,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; @@ -1697,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) @@ -1737,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 (;;) { @@ -1779,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; @@ -1834,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); @@ -1857,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 */ @@ -1950,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"); @@ -1973,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; @@ -2037,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"); @@ -2051,7 +2053,7 @@ PP(pp_enter) PP(pp_leave) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV **newsp; PMOP *newpm; I32 gimme; @@ -2077,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; @@ -2200,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"); @@ -2216,7 +2218,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -2353,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; @@ -2497,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])) @@ -2519,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 */ @@ -2581,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--; @@ -2611,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]); @@ -2646,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++; @@ -2755,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; @@ -2770,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; @@ -2889,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; @@ -3222,7 +3208,7 @@ S_docatch(pTHX_ OP *o) JMPENV_POP; PL_op = oldop; JMPENV_JUMP(ret); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; @@ -3245,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; @@ -3254,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; } @@ -3293,7 +3300,7 @@ S_try_yyparse(pTHX_ int gramtype) default: JMPENV_POP; JMPENV_JUMP(ret); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ } JMPENV_POP; return ret; @@ -3444,6 +3451,7 @@ S_doeval(pTHX_ int gimme, 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; } @@ -3486,6 +3494,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) CopLINE_set(&PL_compiling, 0); SAVEFREEOP(PL_eval_root); + cv_forget_slab(evalcv); DEBUG_x(dump_eval()); @@ -3566,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; @@ -3574,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; @@ -3586,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) { @@ -3658,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; } @@ -3683,6 +3698,8 @@ PP(pp_require) } } + LOADING_FILE_PROBE(unixname); + /* prepare to compile file */ if (path_is_absolute(name)) { @@ -3690,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 @@ -3833,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); @@ -3882,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); @@ -3910,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 ); @@ -3921,6 +3944,7 @@ PP(pp_require) DIE(aTHX_ "Can't locate %s", name); } + CLEAR_ERRSV(); RETPUSHUNDEF; } else @@ -3978,6 +4002,8 @@ PP(pp_require) /* Restore encoding. */ PL_encoding = encoding; + LOADED_FILE_PROBE(unixname); + return op; } @@ -3997,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; @@ -4128,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; @@ -4182,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); @@ -4233,7 +4259,7 @@ PP(pp_leavetry) SV **newsp; PMOP *newpm; I32 gimme; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 optype; PERL_ASYNC_CHECK(); @@ -4253,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); @@ -4271,7 +4304,7 @@ PP(pp_entergiven) PP(pp_leavegiven) { dVAR; dSP; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -4819,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 @@ -4844,7 +4877,7 @@ PP(pp_leavewhen) { dVAR; dSP; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -4888,7 +4921,7 @@ PP(pp_continue) { dVAR; dSP; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; I32 gimme; SV **newsp; PMOP *newpm; @@ -4916,7 +4949,7 @@ PP(pp_break) { dVAR; I32 cxix; - register PERL_CONTEXT *cx; + PERL_CONTEXT *cx; cxix = dopoptogiven(cxstack_ix); if (cxix < 0) @@ -4939,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) */ @@ -5229,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; @@ -5307,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) { @@ -5315,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; @@ -5322,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) { @@ -5336,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; @@ -5365,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); } @@ -5381,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