X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/42b5eca038b6d3e4e05a1ec14af44641f12b87f0..df9e1bc13efe0941735d662db5683d62b3851535:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 3651673..e8fcd46 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -34,7 +34,8 @@ #define PERL_IN_PP_CTL_C #include "perl.h" -#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +#define RUN_PP_CATCHABLY(thispp) \ + STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) @@ -104,18 +105,6 @@ PP(pp_regcomp) assert (re != (REGEXP*) &PL_sv_undef); eng = re ? RX_ENGINE(re) : current_re_engine(); - /* - In the below logic: these are basically the same - check if this regcomp is part of a split. - - (PL_op->op_pmflags & PMf_split ) - (PL_op->op_next->op_type == OP_PUSHRE) - - We could add a new mask for this and copy the PMf_split, if we did - some bit definition fiddling first. - - For now we leave this - */ - new_re = (eng->op_comp ? eng->op_comp : &Perl_re_op_compile @@ -171,13 +160,19 @@ PP(pp_regcomp) RX_TAINT_on(new_re); } + /* handle the empty pattern */ + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) { + if (PL_curpm == PL_reg_curpm) { + if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) { + Perl_croak(aTHX_ "Infinite recursion via empty pattern"); + } + } + } + #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 @@ -218,9 +213,9 @@ PP(pp_substcont) SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ /* See "how taint works" above pp_subst() */ - if (SvTAINTED(TOPs)) - cx->sb_rxtainted |= SUBST_TAINT_REPL; sv_catsv_nomg(dstr, POPs); + if (UNLIKELY(TAINT_get)) + cx->sb_rxtainted |= SUBST_TAINT_REPL; if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, (s == m), cx->sb_targ, NULL, @@ -287,7 +282,7 @@ PP(pp_substcont) TAINT_NOT; CX_LEAVE_SCOPE(cx); - POPSUBST(cx); + CX_POPSUBST(cx); CX_POP(cx); PERL_ASYNC_CHECK(); @@ -490,6 +485,7 @@ PP(pp_formline) U8 *source; /* source of bytes to append */ STRLEN to_copy; /* how may bytes to append */ char trans; /* what chars to translate */ + bool copied_form = FALSE; /* have we duplicated the form? */ mg = doparseform(tmpForm); @@ -504,6 +500,8 @@ PP(pp_formline) SvTAINTED_on(PL_formtarget); if (DO_UTF8(PL_formtarget)) targ_is_utf8 = TRUE; + /* this is an initial estimate of how much output buffer space + * to allocate. It may be exceeded later */ linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); t = SvGROW(PL_formtarget, len + linemax + 1); /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */ @@ -687,6 +685,23 @@ PP(pp_formline) case FF_CHOP: /* (for ^*) chop the current item */ if (sv != &PL_sv_no) { const char *s = chophere; + if (!copied_form && + ((sv == tmpForm || SvSMAGICAL(sv)) + || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) { + /* sv and tmpForm are either the same SV, or magic might allow modification + of tmpForm when sv is modified, so copy */ + SV *newformsv = sv_mortalcopy(formsv); + U32 *new_compiled; + + f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv)); + Newx(new_compiled, mg->mg_len / sizeof(U32), U32); + memcpy(new_compiled, mg->mg_ptr, mg->mg_len); + SAVEFREEPV(new_compiled); + fpc = new_compiled + (fpc - (U32*)mg->mg_ptr); + formsv = newformsv; + + copied_form = TRUE; + } if (chopspace) { while (isSPACE(*s)) s++; @@ -700,6 +715,7 @@ PP(pp_formline) SvSETMAGIC(sv); break; } + /* FALLTHROUGH */ case FF_LINESNGL: /* process ^* */ chopspace = 0; @@ -748,6 +764,7 @@ PP(pp_formline) if (targ_is_utf8 && !item_is_utf8) { source = tmp = bytes_to_utf8(source, &to_copy); + grow = to_copy; } else { if (item_is_utf8 && !targ_is_utf8) { U8 *s; @@ -899,7 +916,7 @@ PP(pp_formline) *t++ = ' '; } s1 = t - 3; - if (strnEQ(s1," ",3)) { + if (strBEGINs(s1," ")) { while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) s1--; } @@ -927,6 +944,7 @@ PP(pp_formline) } } +/* also used for: pp_mapstart() */ PP(pp_grepstart) { dSP; @@ -935,7 +953,7 @@ PP(pp_grepstart) if (PL_stack_base + TOPMARK == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - mXPUSHi(0); + XPUSHs(&PL_sv_zero); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + TOPMARK + 1; @@ -965,7 +983,7 @@ PP(pp_grepstart) PP(pp_mapwhile) { dSP; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */ I32 count; I32 shift; @@ -1105,9 +1123,11 @@ PP(pp_mapwhile) PP(pp_range) { + dTARG; if (GIMME_V == G_ARRAY) return NORMAL; - if (SvTRUEx(PAD_SV(PL_op->op_targ))) + GETTARGET; + if (SvTRUE_NN(targ)) return cLOGOP->op_other; else return NORMAL; @@ -1135,7 +1155,7 @@ PP(pp_flip) flip = SvIV(sv) == SvIV(GvSV(gv)); } } else { - flip = SvTRUE(sv); + flip = SvTRUE_NN(sv); } if (flip) { sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); @@ -1150,7 +1170,7 @@ PP(pp_flip) RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } - sv_setpvs(TARG, ""); + SvPVCLEAR(TARG); SETs(targ); RETURN; } @@ -1221,6 +1241,8 @@ PP(pp_flop) const char * const tmps = SvPV_nomg_const(right, len); SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP); + if (DO_UTF8(right) && IN_UNI_8_BIT) + len = sv_len_utf8_nomg(right); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); if (strEQ(SvPVX_const(sv),tmps)) @@ -1246,7 +1268,7 @@ PP(pp_flop) } } else { - flop = SvTRUE(sv); + flop = SvTRUE_NN(sv); } if (flop) { @@ -1332,14 +1354,14 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) -I32 +U8 Perl_dowantarray(pTHX) { - const I32 gimme = block_gimme(); + const U8 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } -I32 +U8 Perl_block_gimme(pTHX) { const I32 cxix = dopoptosub(cxstack_ix); @@ -1366,7 +1388,7 @@ Perl_is_lvalue_sub(pTHX) return 0; } -/* only used by PUSHSUB */ +/* only used by cx_pushsub() */ I32 Perl_was_lvalue_sub(pTHX) { @@ -1508,7 +1530,7 @@ S_dopoptowhen(pTHX_ I32 startingblock) /* dounwind(): pop all contexts above (but not including) cxix. * Note that it clears the savestack frame associated with each popped * context entry, but doesn't free any temps. - * It does a POPBLOCK of the last frame that it pops, and leaves + * It does a cx_popblock() of the last frame that it pops, and leaves * cxstack_ix equal to cxix. */ @@ -1528,39 +1550,43 @@ Perl_dounwind(pTHX_ I32 cxix) switch (CxTYPE(cx)) { case CXt_SUBST: - POPSUBST(cx); + CX_POPSUBST(cx); + /* CXt_SUBST is not a block context type, so skip the + * cx_popblock(cx) below */ + if (cxstack_ix == cxix + 1) { + cxstack_ix--; + return; + } break; case CXt_SUB: - POPSUB(cx); + cx_popsub(cx); break; case CXt_EVAL: - POPEVAL(cx); - break; - case CXt_BLOCK: - POPBASICBLK(cx); + cx_popeval(cx); break; case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_LIST: case CXt_LOOP_ARY: - POPLOOP(cx); + cx_poploop(cx); break; case CXt_WHEN: - POPWHEN(cx); + cx_popwhen(cx); break; case CXt_GIVEN: - POPGIVEN(cx); + cx_popgiven(cx); break; + case CXt_BLOCK: case CXt_NULL: - /* there isn't a POPNULL ! */ + /* these two don't have a POPFOO() */ break; case CXt_FORMAT: - POPFORMAT(cx); + cx_popformat(cx); break; } if (cxstack_ix == cxix + 1) { - POPBLOCK(cx); + cx_popblock(cx); } cxstack_ix--; } @@ -1574,7 +1600,7 @@ Perl_qerror(pTHX_ SV *err) if (PL_in_eval) { if (PL_in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, SVfARG(err)); } else @@ -1583,49 +1609,87 @@ Perl_qerror(pTHX_ SV *err) else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%"SVf, SVfARG(err)); + Perl_warn(aTHX_ "%" SVf, SVfARG(err)); if (PL_parser) ++PL_parser->error_count; } -/* undef or delete the $INC{namesv} entry, then croak. - * require0 indicates that the require didn't return a true value */ +/* pop a CXt_EVAL context and in addition, if it was a require then + * based on action: + * 0: do nothing extra; + * 1: undef $INC{$name}; croak "$name did not return a true value"; + * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require" + */ static void -S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0) +S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action) { - const char *fmt; - HV *inc_hv = GvHVn(PL_incgv); - I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); - const char *key = SvPVX_const(namesv); + SV *namesv = NULL; /* init to avoid dumb compiler warning */ + bool do_croak; - if (require0) { - (void)hv_delete(inc_hv, key, klen, G_DISCARD); - fmt = "%"SVf" did not return a true value"; - err = namesv; - } - else { - (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); - fmt = "%"SVf"Compilation failed in require"; - err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP); + CX_LEAVE_SCOPE(cx); + do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE); + if (do_croak) { + /* keep namesv alive after cx_popeval() */ + namesv = cx->blk_eval.old_namesv; + cx->blk_eval.old_namesv = NULL; + sv_2mortal(namesv); } + cx_popeval(cx); + cx_popblock(cx); + CX_POP(cx); + + if (do_croak) { + const char *fmt; + HV *inc_hv = GvHVn(PL_incgv); + I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); + const char *key = SvPVX_const(namesv); - Perl_croak(aTHX_ fmt, SVfARG(err)); + if (action == 1) { + (void)hv_delete(inc_hv, key, klen, G_DISCARD); + fmt = "%" SVf " did not return a true value"; + errsv = namesv; + } + else { + (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); + fmt = "%" SVf "Compilation failed in require"; + if (!errsv) + errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP); + } + + Perl_croak(aTHX_ fmt, SVfARG(errsv)); + } } +/* die_unwind(): this is the final destination for the various croak() + * functions. If we're in an eval, unwind the context and other stacks + * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv + * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back + * to is a require the exception will be rethrown, as requires don't + * actually trap exceptions. + */ + void Perl_die_unwind(pTHX_ SV *msv) { - SV *exceptsv = sv_mortalcopy(msv); + SV *exceptsv = msv; U8 in_eval = PL_in_eval; PERL_ARGS_ASSERT_DIE_UNWIND; if (in_eval) { I32 cxix; + /* We need to keep this SV alive through all the stack unwinding + * and FREETMPSing below, while ensuing that it doesn't leak + * if we call out to something which then dies (e.g. sub STORE{die} + * when unlocalising a tied var). So we do a dance with + * mortalising and SAVEFREEing. + */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + /* * Historically, perl used to set ERRSV ($@) early in the die * process and rely on it not getting clobbered during unwinding. @@ -1655,13 +1719,12 @@ Perl_die_unwind(pTHX_ SV *msv) * perls 5.13.{1..7} which had late setting of $@ without this * early-setting hack. */ - if (!(in_eval & EVAL_KEEPERR)) { - SvTEMP_off(exceptsv); - sv_setsv(ERRSV, exceptsv); - } + if (!(in_eval & EVAL_KEEPERR)) + sv_setsv_flags(ERRSV, exceptsv, + (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); if (in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, SVfARG(exceptsv)); } @@ -1673,10 +1736,9 @@ Perl_die_unwind(pTHX_ SV *msv) } if (cxix >= 0) { - SV *namesv = NULL; PERL_CONTEXT *cx; SV **oldsp; - I32 gimme; + U8 gimme; JMPENV *restartjmpenv; OP *restartop; @@ -1693,23 +1755,33 @@ Perl_die_unwind(pTHX_ SV *msv) *++oldsp = &PL_sv_undef; PL_stack_sp = oldsp; - CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); restartjmpenv = cx->blk_eval.cur_top_env; - restartop = cx->blk_eval.retop; - if (CxOLD_OP_TYPE(cx) == OP_REQUIRE) - namesv = cx->blk_eval.old_namesv; - CX_POP(cx); - - if (namesv) { - /* note that unlike pp_entereval, pp_require isn't - * supposed to trap errors. So now that we've popped the - * EVAL that pp_require pushed, process the error message - * and rethrow the error */ - S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE); - NOT_REACHED; /* NOTREACHED */ - } + restartop = cx->blk_eval.retop; + + /* We need a FREETMPS here to avoid late-called destructors + * clobbering $@ *after* we set it below, e.g. + * sub DESTROY { eval { die "X" } } + * eval { my $x = bless []; die $x = 0, "Y" }; + * is($@, "Y") + * Here the clearing of the $x ref mortalises the anon array, + * which needs to be freed *before* $& is set to "Y", + * otherwise it gets overwritten with "X". + * + * However, the FREETMPS will clobber exceptsv, so preserve it + * on the savestack for now. + */ + SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv)); + FREETMPS; + /* now we're about to pop the savestack, so re-mortalise it */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + + /* Note that unlike pp_entereval, pp_require isn't supposed to + * trap errors. So if we're a require, after we pop the + * CXt_EVAL that pp_require pushed, rethrow the error with + * croak(exceptsv). This is all handled by the call below when + * action == 2. + */ + S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2); if (!(in_eval & EVAL_KEEPERR)) sv_setsv(ERRSV, exceptsv); @@ -1728,7 +1800,7 @@ Perl_die_unwind(pTHX_ SV *msv) PP(pp_xor) { dSP; dPOPTOPssrl; - if (SvTRUE(left) != SvTRUE(right)) + if (SvTRUE_NN(left) != SvTRUE_NN(right)) RETSETYES; else RETSETNO; @@ -1802,7 +1874,7 @@ PP(pp_caller) dSP; const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; - I32 gimme = GIMME_V; + U8 gimme = GIMME_V; const HEK *stash_hek; I32 count = 0; bool has_arg = MAXARG && TOPs; @@ -1870,9 +1942,9 @@ PP(pp_caller) } else { PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); - mPUSHi(0); + PUSHs(&PL_sv_zero); } - gimme = (I32)cx->blk_gimme; + gimme = cx->blk_gimme; if (gimme == G_VOID) PUSHs(&PL_sv_undef); else @@ -1920,7 +1992,8 @@ PP(pp_caller) if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) av_extend(PL_dbargs, AvFILLp(ary) + off); - Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); + if (AvFILLp(ary) + 1 + off) + Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); AvFILLp(PL_dbargs) = AvFILLp(ary) + off; } mPUSHi(CopHINTS_get(cx->blk_oldcop)); @@ -1934,16 +2007,7 @@ PP(pp_caller) mask = &PL_sv_undef ; else if (old_warnings == pWARN_ALL || (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { - /* Get the bit mask for $warnings::Bits{all}, because - * it could have been extended by warnings::register */ - SV **bits_all; - HV * const bits = get_hv("warnings::Bits", 0); - if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { - mask = newSVsv(*bits_all); - } - else { - mask = newSVpvn(WARN_ALLstring, WARNsize) ; - } + mask = newSVpvn(WARN_ALLstring, WARNsize) ; } else mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); @@ -1961,8 +2025,10 @@ PP(pp_reset) dSP; const char * tmps; STRLEN len = 0; - if (MAXARG < 1 || (!TOPs && !POPs)) + if (MAXARG < 1 || (!TOPs && !POPs)) { + EXTEND(SP, 1); tmps = NULL, len = 0; + } else tmps = SvPVx_const(POPs, len); sv_resetpvn(tmps, len, CopSTASH(PL_curcop)); @@ -1986,7 +2052,7 @@ PP(pp_dbstate) { dSP; PERL_CONTEXT *cx; - const I32 gimme = G_ARRAY; + const U8 gimme = G_ARRAY; GV * const gv = PL_DBgv; CV * cv = NULL; @@ -2013,20 +2079,19 @@ PP(pp_dbstate) return NORMAL; } else { - U8 hasargs = 0; - PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB_DB(cx); - cx->blk_sub.retop = PL_op->op_next; - cx->blk_oldsaveix = PL_savestack_ix; + cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix); + cx_pushsub(cx, cv, PL_op->op_next, 0); + /* OP_DBSTATE's op_private holds hint bits rather than + * the lvalue-ish flags seen in OP_ENTERSUB. So cancel + * any CxLVAL() flags that have now been mis-calculated */ + cx->blk_u16 = 0; SAVEI32(PL_debug); PL_debug = 0; SAVESTACK_POS(); CvDEPTH(cv)++; - if (CvDEPTH(cv) >= 2) { - PERL_STACK_OVERFLOW_CHECK(); + if (CvDEPTH(cv) >= 2) pad_push(CvPADLIST(cv), CvDEPTH(cv)); - } PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); RETURNOP(CvSTART(cv)); } @@ -2038,27 +2103,25 @@ PP(pp_dbstate) PP(pp_enter) { - dSP; - PERL_CONTEXT *cx; - I32 gimme = GIMME_V; - - PUSHBLOCK(cx, CXt_BLOCK, SP); - PUSHBASICBLK(cx); + U8 gimme = GIMME_V; - RETURN; + (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix); + return NORMAL; } + PP(pp_leave) { PERL_CONTEXT *cx; SV **oldsp; - I32 gimme; + U8 gimme; cx = CX_CUR(); assert(CxTYPE(cx) == CXt_BLOCK); if (PL_op->op_flags & OPf_SPECIAL) - cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ + /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */ + cx->blk_oldpm = PL_curpm; oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; @@ -2070,8 +2133,7 @@ PP(pp_leave) PL_op->op_private & OPpLVALUE ? 3 : 1); CX_LEAVE_SCOPE(cx); - POPBASICBLK(cx); - POPBLOCK(cx); + cx_popblock(cx); CX_POP(cx); return NORMAL; @@ -2103,7 +2165,7 @@ PP(pp_enteriter) { dSP; dMARK; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; void *itervarp; /* GV or pad slot of the iteration variable */ SV *itersave; /* the old var in the iterator var slot */ U8 cxflags = 0; @@ -2142,8 +2204,13 @@ PP(pp_enteriter) /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */ assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF)); - PUSHBLOCK(cx, cxflags, MARK); - PUSHLOOP_FOR(cx, itervarp, itersave); + /* Note that this context is initially set as CXt_NULL. Further on + * down it's changed to one of the CXt_LOOP_*. Before it's changed, + * there mustn't be anything in the blk_loop substruct that requires + * freeing or undoing, in case we die in the meantime. And vice-versa. + */ + cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix); + cx_pushloop_for(cx, itervarp, itersave); if (PL_op->op_flags & OPf_STACKED) { /* OPf_STACKED implies either a single array: for(@), with a @@ -2213,40 +2280,39 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; - PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); - PUSHLOOP_PLAIN(cx); - - RETURN; + cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix); + cx_pushloop_plain(cx); + return NORMAL; } + PP(pp_leaveloop) { PERL_CONTEXT *cx; - I32 gimme; + U8 gimme; + SV **base; SV **oldsp; - SV **mark; cx = CX_CUR(); assert(CxTYPE_is_LOOP(cx)); - mark = PL_stack_base + cx->blk_oldsp; - oldsp = CxTYPE(cx) == CXt_LOOP_LIST + oldsp = PL_stack_base + cx->blk_oldsp; + base = CxTYPE(cx) == CXt_LOOP_LIST ? PL_stack_base + cx->blk_loop.state_u.stack.basesp - : mark; + : oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = oldsp; + PL_stack_sp = base; else - leave_adjust_stacks(MARK, oldsp, gimme, + leave_adjust_stacks(oldsp, base, gimme, PL_op->op_private & OPpLVALUE ? 3 : 1); CX_LEAVE_SCOPE(cx); - POPLOOP(cx); /* Stack values are safe: release loop vars ... */ - POPBLOCK(cx); + cx_poploop(cx); /* Stack values are safe: release loop vars ... */ + cx_popblock(cx); CX_POP(cx); return NORMAL; @@ -2259,11 +2325,13 @@ PP(pp_leaveloop) * * Any changes made to this function may need to be copied to pp_leavesub * and vice-versa. + * + * also tail-called by pp_return */ PP(pp_leavesublv) { - I32 gimme; + U8 gimme; PERL_CONTEXT *cx; SV **oldsp; OP *retop; @@ -2352,8 +2420,8 @@ PP(pp_leavesublv) } CX_LEAVE_SCOPE(cx); - POPSUB(cx); /* Stack values are safe: release CV and @_ ... */ - POPBLOCK(cx); + cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */ + cx_popblock(cx); retop = cx->blk_sub.retop; CX_POP(cx); @@ -2400,20 +2468,18 @@ PP(pp_return) } /* There are contexts that need popping. Doing this may free the - * return value(s), so preserve them first, e.g. popping the plain + * return value(s), so preserve them first: e.g. popping the plain * loop here would free $x: * sub f { { my $x = 1; return $x } } * We may also need to shift the args down; for example, * for (1,2) { return 3,4 } - * leaves 1,2,3,4 on the stack. Both these actions can be done by - * leave_adjust_stacks(). By calling it with and lvalue "pass - * all" action, we just bump the ref count and mortalise the args - * that need it, do a FREETMPS. The "scan the args and maybe copy - * them" process will be repeated by whoever we tail-call (e.g. - * pp_leaveeval), where any copying etc will be done. That is to - * say, in this code path two scans of the args will be done; the - * first just shifts and preserves; the second is the "real" arg - * processing, based on the type of return. + * leaves 1,2,3,4 on the stack. Both these actions will be done by + * leave_adjust_stacks(), along with freeing any temps. Note that + * whoever we tail-call (e.g. pp_leaveeval) will also call + * leave_adjust_stacks(); however, the second call is likely to + * just see a bunch of SvTEMPs with a ref count of 1, and so just + * pass them through, rather than copying them again. So this + * isn't as inefficient as it sounds. */ cx = &cxstack[cxix]; PUTBACK; @@ -2475,7 +2541,7 @@ PP(pp_return) /* find the enclosing loop or labelled loop and dounwind() back to it. */ -PERL_CONTEXT * +static PERL_CONTEXT * S_unwind_loop(pTHX) { I32 cxix; @@ -2501,7 +2567,7 @@ S_unwind_loop(pTHX) cxix = dopoptolabel(label, label_len, label_flags); if (cxix < 0) /* diag_listed_as: Label not found for "last %s" */ - Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", + Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"", OP_NAME(PL_op), SVfARG(PL_op->op_flags & OPf_STACKED && !SvGMAGICAL(TOPp1s) @@ -2534,8 +2600,8 @@ PP(pp_last) /* Stack values are safe: */ CX_LEAVE_SCOPE(cx); - POPLOOP(cx); /* release loop vars ... */ - POPBLOCK(cx); + cx_poploop(cx); /* release loop vars ... */ + cx_popblock(cx); nextop = cx->blk_loop.my_op->op_lastop->op_next; CX_POP(cx); @@ -2546,9 +2612,12 @@ PP(pp_next) { PERL_CONTEXT *cx; - cx = S_unwind_loop(aTHX); + /* if not a bare 'next' in the main scope, search for it */ + cx = CX_CUR(); + if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx))) + cx = S_unwind_loop(aTHX); - TOPBLOCK(cx); + cx_topblock(cx); PL_curcop = cx->blk_oldcop; PERL_ASYNC_CHECK(); return (cx)->blk_loop.my_op->op_nextop; @@ -2567,9 +2636,9 @@ PP(pp_redo) redo_op = redo_op->op_next; } - TOPBLOCK(cx); - CX_LEAVE_SCOPE(cx); FREETMPS; + CX_LEAVE_SCOPE(cx); + cx_topblock(cx); PL_curcop = cx->blk_oldcop; PERL_ASYNC_CHECK(); return redo_op; @@ -2684,7 +2753,7 @@ PP(pp_goto) continue; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); + DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); } @@ -2714,7 +2783,7 @@ PP(pp_goto) dounwind(cxix); } cx = CX_CUR(); - TOPBLOCK(cx); + cx_topblock(cx); SPAGAIN; /* protect @_ during save stack unwind. */ @@ -2725,7 +2794,7 @@ PP(pp_goto) CX_LEAVE_SCOPE(cx); if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { - /* this is part of POPSUB_ARGS() */ + /* this is part of cx_popsub_args() */ AV* av = MUTABLE_AV(PAD_SVl(0)); assert(AvARRAY(MUTABLE_AV( PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ @@ -2755,7 +2824,7 @@ PP(pp_goto) if (gv) { SV * const tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"", + DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); @@ -2800,7 +2869,7 @@ PP(pp_goto) SP += items; if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { /* Restore old @_ */ - POP_SAVEARRAY(cx); + CX_POP_SAVEARRAY(cx); } retop = cx->blk_sub.retop; @@ -2808,8 +2877,8 @@ PP(pp_goto) PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; /* XS subs don't have a CXt_SUB, so pop it; - * this is a POPBLOCK(), less all the stuff we already did - * for TOPBLOCK() earlier */ + * this is a cx_popblock(), less all the stuff we already did + * for cx_topblock() earlier */ PL_curcop = cx->blk_oldcop; CX_POP(cx); @@ -2825,7 +2894,7 @@ PP(pp_goto) SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ - /* partial unrolled PUSHSUB(): */ + /* partial unrolled cx_pushsub(): */ cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); @@ -2896,6 +2965,7 @@ PP(pp_goto) OP *gotoprobe = NULL; bool leaving_eval = FALSE; bool in_block = FALSE; + bool pseudo_block = FALSE; PERL_CONTEXT *last_eval_cx = NULL; /* find label */ @@ -2934,11 +3004,9 @@ PP(pp_goto) gotoprobe = PL_main_root; break; case CXt_SUB: - if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { - gotoprobe = CvROOT(cx->blk_sub.cv); - break; - } - /* FALLTHROUGH */ + gotoprobe = CvROOT(cx->blk_sub.cv); + pseudo_block = cBOOL(CxMULTICALL(cx)); + break; case CXt_FORMAT: case CXt_NULL: DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); @@ -2967,10 +3035,12 @@ PP(pp_goto) break; } } + if (pseudo_block) + DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); PL_lastgotoprobe = gotoprobe; } if (!retop) - DIE(aTHX_ "Can't find label %"UTF8f, + DIE(aTHX_ "Can't find label %" UTF8f, UTF8fARG(label_flags, label_len, label)); /* if we're leaving an eval, check before we pop any frames @@ -2997,7 +3067,7 @@ PP(pp_goto) DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); dounwind(ix); cx = CX_CUR(); - TOPBLOCK(cx); + cx_topblock(cx); } /* push wanted frames */ @@ -3105,23 +3175,18 @@ establish a local jmpenv to handle exception traps. =cut */ STATIC OP * -S_docatch(pTHX_ OP *o) +S_docatch(pTHX_ Perl_ppaddr_t firstpp) { int ret; OP * const oldop = PL_op; dJMPENV; -#ifdef DEBUGGING assert(CATCH_GET == TRUE); -#endif - PL_op = o; JMPENV_PUSH(ret); switch (ret) { case 0: - assert(cxstack_ix >= 0); - assert(CxTYPE(CX_CUR()) == CXt_EVAL); - CX_CUR()->blk_eval.cur_top_env = PL_top_env; + PL_op = firstpp(aTHX); redo_body: CALLRUNOPS(aTHX); break; @@ -3203,7 +3268,7 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) return cv; case FIND_RUNCV_level_eq: if (level++ != arg) continue; - /* GERONIMO! */ + /* FALLTHROUGH */ default: return cv; } @@ -3258,7 +3323,7 @@ S_try_yyparse(pTHX_ int gramtype) */ STATIC bool -S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) +S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) { dSP; OP * const saveop = PL_op; @@ -3299,7 +3364,11 @@ S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) SAVEGENERICSV(PL_curstash); PL_curstash = (HV *)CopSTASH(PL_curcop); if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL; - else SvREFCNT_inc_simple_void(PL_curstash); + else { + SvREFCNT_inc_simple_void(PL_curstash); + save_item(PL_curstname); + sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash)); + } } /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); @@ -3330,7 +3399,7 @@ S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) } else { PL_hints = saveop->op_private & OPpEVAL_COPHH - ? oldcurcop->cop_hints : saveop->op_targ; + ? oldcurcop->cop_hints : (U32)saveop->op_targ; /* making 'use re eval' not be in scope when compiling the * qr/mabye_has_runtime_code_block/ ensures that we don't get @@ -3382,7 +3451,6 @@ S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); if (yystatus || PL_parser->error_count || !PL_eval_root) { - SV *namesv = NULL; /* initialise to avoid compiler warning */ PERL_CONTEXT *cx; SV *errsv; @@ -3397,25 +3465,17 @@ S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) } SP = PL_stack_base + POPMARK; /* pop original mark */ cx = CX_CUR(); - CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); - if (in_require) - namesv = cx->blk_eval.old_namesv; - CX_POP(cx); + assert(CxTYPE(cx) == CXt_EVAL); + /* pop the CXt_EVAL, and if was a require, croak */ + S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2); } - errsv = ERRSV; - if (in_require) { - if (yystatus == 3) { - cx = CX_CUR(); - assert(CxTYPE(cx) == CXt_EVAL); - namesv = cx->blk_eval.old_namesv; - } - S_undo_inc_then_croak(aTHX_ namesv, errsv, FALSE); - NOT_REACHED; /* NOTREACHED */ - } + /* die_unwind() re-croaks when in require, having popped the + * require EVAL context. So we should never catch a require + * exception here */ + assert(!in_require); + errsv = ERRSV; if (!*(SvPV_nolen_const(errsv))) sv_setpvs(errsv, "Compilation error"); @@ -3461,6 +3521,9 @@ S_doeval_compile(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) return TRUE; } +/* Return NULL if the file doesn't exist or isn't a file; + * else return PerlIO_openn(). + */ STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) @@ -3490,15 +3553,22 @@ S_check_type_and_open(pTHX_ SV *name) 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 */ - errno = 0; - st_rc = PerlLIO_stat(p, &st); - if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { + if (st_rc < 0) return NULL; + else { + int eno; + if(S_ISBLK(st.st_mode)) { + eno = EINVAL; + goto not_file; + } + else if(S_ISDIR(st.st_mode)) { + eno = EISDIR; + not_file: + errno = eno; + return NULL; + } } #endif @@ -3510,8 +3580,10 @@ S_check_type_and_open(pTHX_ SV *name) 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; + if(S_ISDIR(st.st_mode)) + eno = EISDIR; + else if(S_ISBLK(st.st_mode)) + eno = EINVAL; else eno = EACCES; errno = eno; @@ -3521,6 +3593,11 @@ S_check_type_and_open(pTHX_ SV *name) return retio; } +/* doopen_pm(): return the equivalent of PerlIO_openn() on the given name, + * but first check for bad names (\0) and non-files. + * Also if the filename ends in .pm and unless PERL_DISABLE_PMC, + * try loading Foo.pmc first. + */ #ifndef PERL_DISABLE_PMC STATIC PerlIO * S_doopen_pm(pTHX_ SV *name) @@ -3537,7 +3614,7 @@ S_doopen_pm(pTHX_ SV *name) if (!IS_SAFE_PATHNAME(p, namelen, "require")) return NULL; - if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) { + if (memENDPs(p, namelen, ".pm")) { SV *const pmcsv = sv_newmortal(); PerlIO * pmcio; @@ -3554,8 +3631,8 @@ S_doopen_pm(pTHX_ SV *name) # define doopen_pm(name) check_type_and_open(name) #endif /* !PERL_DISABLE_PMC */ -/* require doesn't search for absolute names, or when the name is - explicitly relative the current directory */ +/* require doesn't search in @INC for absolute names, or when the name is + explicitly relative the current directory: i.e. ./, ../ */ PERL_STATIC_INLINE bool S_path_is_searchable(const char *name) { @@ -3581,13 +3658,80 @@ S_path_is_searchable(const char *name) } -/* also used for: pp_dofile() */ +/* implement 'require 5.010001' */ -PP(pp_require) +static OP * +S_require_version(pTHX_ SV *sv) { - dSP; + dVAR; dSP; + + sv = sv_2mortal(new_version(sv)); + if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) + upg_version(PL_patchlevel, TRUE); + if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { + if ( vcmp(sv,PL_patchlevel) <= 0 ) + DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped", + SVfARG(sv_2mortal(vnormal(sv))), + SVfARG(sv_2mortal(vnormal(PL_patchlevel))) + ); + } + else { + if ( vcmp(sv,PL_patchlevel) > 0 ) { + I32 first = 0; + AV *lav; + SV * const req = SvRV(sv); + SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); + + /* get the left hand term */ + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); + + first = SvIV(*av_fetch(lav,0,0)); + if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ + || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ + || av_tindex(lav) > 1 /* FP with > 3 digits */ + || strstr(SvPVX(pv),".0") /* FP with leading 0 */ + ) { + DIE(aTHX_ "Perl %" SVf " required--this is only " + "%" SVf ", stopped", + SVfARG(sv_2mortal(vnormal(req))), + SVfARG(sv_2mortal(vnormal(PL_patchlevel))) + ); + } + else { /* probably 'use 5.10' or 'use 5.8' */ + SV *hintsv; + I32 second = 0; + + if (av_tindex(lav)>=1) + second = SvIV(*av_fetch(lav,1,0)); + + second /= second >= 600 ? 100 : 10; + hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", + (int)first, (int)second); + upg_version(hintsv, TRUE); + + DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)" + "--this is only %" SVf ", stopped", + SVfARG(sv_2mortal(vnormal(req))), + SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), + SVfARG(sv_2mortal(vnormal(PL_patchlevel))) + ); + } + } + } + + RETPUSHYES; +} + +/* Handle C, C and C. + * The first form will have already been converted at compile time to + * the second form */ + +static OP * +S_require_file(pTHX_ SV *sv) +{ + dVAR; dSP; + PERL_CONTEXT *cx; - SV *sv; const char *name; STRLEN len; char * unixname; @@ -3596,9 +3740,11 @@ PP(pp_require) int vms_unixname = 0; char *unixdir; #endif + /* tryname is the actual pathname (with @INC prefix) which was loaded. + * It's stored as a value in %INC, and used for error messages */ const char *tryname = NULL; - SV *namesv = NULL; - const I32 gimme = GIMME_V; + SV *namesv = NULL; /* SV equivalent of tryname */ + const U8 gimme = GIMME_V; int filter_has_file = 0; PerlIO *tryrsfp = NULL; SV *filter_cache = NULL; @@ -3609,79 +3755,38 @@ PP(pp_require) int saved_errno; bool path_searchable; I32 old_savestack_ix; + const bool op_is_require = PL_op->op_type == OP_REQUIRE; + const char *const op_name = op_is_require ? "require" : "do"; + SV ** svp_cached = NULL; - sv = POPs; - SvGETMAGIC(sv); - if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { - sv = sv_2mortal(new_version(sv)); - if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) - upg_version(PL_patchlevel, TRUE); - if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { - if ( vcmp(sv,PL_patchlevel) <= 0 ) - DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", - SVfARG(sv_2mortal(vnormal(sv))), - SVfARG(sv_2mortal(vnormal(PL_patchlevel))) - ); - } - else { - if ( vcmp(sv,PL_patchlevel) > 0 ) { - I32 first = 0; - AV *lav; - SV * const req = SvRV(sv); - SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); - - /* get the left hand term */ - lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); - - first = SvIV(*av_fetch(lav,0,0)); - if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ - || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ - || av_tindex(lav) > 1 /* FP with > 3 digits */ - || strstr(SvPVX(pv),".0") /* FP with leading 0 */ - ) { - DIE(aTHX_ "Perl %"SVf" required--this is only " - "%"SVf", stopped", - SVfARG(sv_2mortal(vnormal(req))), - SVfARG(sv_2mortal(vnormal(PL_patchlevel))) - ); - } - else { /* probably 'use 5.10' or 'use 5.8' */ - SV *hintsv; - I32 second = 0; - - if (av_tindex(lav)>=1) - second = SvIV(*av_fetch(lav,1,0)); - - second /= second >= 600 ? 100 : 10; - hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", - (int)first, (int)second); - upg_version(hintsv, TRUE); - - DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" - "--this is only %"SVf", stopped", - SVfARG(sv_2mortal(vnormal(req))), - SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), - SVfARG(sv_2mortal(vnormal(PL_patchlevel))) - ); - } - } - } + assert(op_is_require || PL_op->op_type == OP_DOFILE); - RETPUSHYES; - } if (!SvOK(sv)) - DIE(aTHX_ "Missing or undefined argument to require"); + DIE(aTHX_ "Missing or undefined argument to %s", op_name); name = SvPV_nomg_const(sv, len); if (!(name && len > 0 && *name)) - DIE(aTHX_ "Missing or undefined argument to require"); + DIE(aTHX_ "Missing or undefined argument to %s", op_name); + +#ifndef VMS + /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */ + if (op_is_require) { + /* can optimize to only perform one single lookup */ + svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0); + if ( svp_cached && *svp_cached != &PL_sv_undef ) RETPUSHYES; + } +#endif - if (!IS_SAFE_PATHNAME(name, len, "require")) { + if (!IS_SAFE_PATHNAME(name, len, op_name)) { + if (!op_is_require) { + CLEAR_ERRSV(); + RETPUSHUNDEF; + } DIE(aTHX_ "Can't locate %s: %s", - pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv), - SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), + pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2, + NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), Strerror(ENOENT)); } - TAINT_PROPER("require"); + TAINT_PROPER(op_name); path_searchable = path_is_searchable(name); @@ -3708,9 +3813,9 @@ PP(pp_require) unixname = (char *) name; unixlen = len; } - if (PL_op->op_type == OP_REQUIRE) { - SV * const * const svp = hv_fetch(GvHVn(PL_incgv), - unixname, unixlen, 0); + if (op_is_require) { + /* reuse the previous hv_fetch result if possible */ + SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); if ( svp ) { if (*svp != &PL_sv_undef) RETPUSHYES; @@ -3718,17 +3823,72 @@ PP(pp_require) DIE(aTHX_ "Attempt to reload %s aborted.\n" "Compilation failed in require", unixname); } + + /*XXX OPf_KIDS should always be true? -dapm 4/2017 */ + if (PL_op->op_flags & OPf_KIDS) { + SVOP * const kid = (SVOP*)cUNOP->op_first; + + if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + /* Make sure that a bareword module name (e.g. ::Foo::Bar) + * doesn't map to a naughty pathname like /Foo/Bar.pm. + * Note that the parser will normally detect such errors + * at compile time before we reach here, but + * Perl_load_module() can fake up an identical optree + * without going near the parser, and being able to put + * anything as the bareword. So we include a duplicate set + * of checks here at runtime. + */ + const STRLEN package_len = len - 3; + const char slashdot[2] = {'/', '.'}; +#ifdef DOSISH + const char backslashdot[2] = {'\\', '.'}; +#endif + + /* Disallow *purported* barewords that map to absolute + filenames, filenames relative to the current or parent + directory, or (*nix) hidden filenames. Also sanity check + that the generated filename ends .pm */ + if (!path_searchable || len < 3 || name[0] == '.' + || !memEQs(name + package_len, len - package_len, ".pm")) + DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv); + if (memchr(name, 0, package_len)) { + /* diag_listed_as: Bareword in require contains "%s" */ + DIE(aTHX_ "Bareword in require contains \"\\0\""); + } + if (ninstr(name, name + package_len, slashdot, + slashdot + sizeof(slashdot))) { + /* diag_listed_as: Bareword in require contains "%s" */ + DIE(aTHX_ "Bareword in require contains \"/.\""); + } +#ifdef DOSISH + if (ninstr(name, name + package_len, backslashdot, + backslashdot + sizeof(backslashdot))) { + /* diag_listed_as: Bareword in require contains "%s" */ + DIE(aTHX_ "Bareword in require contains \"\\.\""); + } +#endif + } + } } - LOADING_FILE_PROBE(unixname); + PERL_DTRACE_PROBE_FILE_LOADING(unixname); - /* prepare to compile file */ + /* Try to locate and open a file, possibly using @INC */ + /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load + * the file directly rather than via @INC ... */ if (!path_searchable) { /* At this point, name is SvPVX(sv) */ tryname = name; tryrsfp = doopen_pm(sv); } + + /* ... but if we fail, still search @INC for code references; + * these are applied even on on-searchable paths (except + * if we got EACESS). + * + * For searchable paths, just search @INC normally + */ if (!tryrsfp && !(errno == EACCES && !path_searchable)) { AV * const ar = GvAVn(PL_incgv); SSize_t i; @@ -3754,7 +3914,7 @@ PP(pp_require) SvGETMAGIC(loader); } - Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", + Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s", PTR2UV(SvRV(dirsv)), name); tryname = SvPVX_const(namesv); tryrsfp = NULL; @@ -3871,8 +4031,9 @@ PP(pp_require) filter_sub = NULL; } } - else { - if (path_searchable) { + else if (path_searchable) { + /* match against a plain @INC element (non-searchable + * paths are only matched against refs in @INC) */ const char *dir; STRLEN dirlen; @@ -3883,7 +4044,7 @@ PP(pp_require) dirlen = 0; } - if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require")) + if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name)) continue; #ifdef VMS if ((unixdir = @@ -3892,8 +4053,7 @@ PP(pp_require) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -#else -# ifdef __SYMBIAN32__ +#elif defined(__SYMBIAN32__) if (PL_origfilename[0] && PL_origfilename[1] == ':' && !(dir[0] && dir[1] == ':')) @@ -3905,7 +4065,7 @@ PP(pp_require) Perl_sv_setpvf(aTHX_ namesv, "%s\\%s", dir, name); -# else +#else /* The equivalent of Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); but without the need to parse the format string, or @@ -3932,9 +4092,8 @@ PP(pp_require) SvCUR_set(namesv, dirlen + len + 1); SvPOK_on(namesv); } -# endif #endif - TAINT_PROPER("require"); + TAINT_PROPER(op_name); tryname = SvPVX_const(namesv); tryrsfp = doopen_pm(namesv); if (tryrsfp) { @@ -3952,21 +4111,24 @@ PP(pp_require) */ break; } - } } } } } + + /* at this point we've ether opened a file (tryrsfp) or set errno */ + saved_errno = errno; /* sv_2mortal can realloc things */ sv_2mortal(namesv); if (!tryrsfp) { - if (PL_op->op_type == OP_REQUIRE) { + /* we failed; croak if require() or return undef if do() */ + if (op_is_require) { if(saved_errno == EMFILE || saved_errno == EACCES) { /* diag_listed_as: Can't locate %s */ DIE(aTHX_ "Can't locate %s: %s: %s", name, tryname, Strerror(saved_errno)); } else { - if (namesv) { /* did we lookup @INC? */ + if (path_searchable) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); SSize_t i; SV *const msg = newSVpvs_flags("", SVs_TEMP); @@ -3975,23 +4137,53 @@ PP(pp_require) sv_catpvs(inc, " "); sv_catsv(inc, *av_fetch(ar, i, TRUE)); } - if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) { - const char *c, *e = name + len - 3; - sv_catpv(msg, " (you may need to install the "); - for (c = name; c < e; c++) { - if (*c == '/') { - sv_catpvs(msg, "::"); - } - else { - sv_catpvn(msg, c, 1); - } - } - sv_catpv(msg, " module)"); + if (memENDPs(name, len, ".pm")) { + const char *e = name + len - (sizeof(".pm") - 1); + const char *c; + bool utf8 = cBOOL(SvUTF8(sv)); + + /* if the filename, when converted from "Foo/Bar.pm" + * form back to Foo::Bar form, makes a valid + * package name (i.e. parseable by C), then emit a hint. + * + * this loop is modelled after the one in + S_parse_ident */ + c = name; + while (c < e) { + if (utf8 && isIDFIRST_utf8_safe(c, e)) { + c += UTF8SKIP(c); + while (c < e && isIDCONT_utf8_safe( + (const U8*) c, (const U8*) e)) + c += UTF8SKIP(c); + } + else if (isWORDCHAR_A(*c)) { + while (c < e && isWORDCHAR_A(*c)) + c++; + } + else if (*c == '/') + c++; + else + break; + } + + if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) { + sv_catpv(msg, " (you may need to install the "); + for (c = name; c < e; c++) { + if (*c == '/') { + sv_catpvs(msg, "::"); + } + else { + sv_catpvn(msg, c, 1); + } + } + sv_catpv(msg, " module)"); + } } - else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) { + else if (memENDs(name, len, ".h")) { sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); } - else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) { + else if (memENDs(name, len, ".ph")) { sv_catpv(msg, " (did you run h2ph?)"); } @@ -4003,14 +4195,36 @@ PP(pp_require) } DIE(aTHX_ "Can't locate %s", name); } - - CLEAR_ERRSV(); - RETPUSHUNDEF; + else { +#ifdef DEFAULT_INC_EXCLUDES_DOT + Stat_t st; + PerlIO *io = NULL; + dSAVE_ERRNO; + /* the complication is to match the logic from doopen_pm() so + * we don't treat do "sda1" as a previously successful "do". + */ + bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED) + && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode) + && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL; + if (io) + PerlIO_close(io); + + RESTORE_ERRNO; + if (do_warn) { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + "do \"%s\" failed, '.' is no longer in @INC; " + "did you mean do \"./%s\"?", + name, name); + } +#endif + CLEAR_ERRSV(); + RETPUSHUNDEF; + } } else SETERRNO(0, SS_NORMAL); - /* Assume success here to prevent recursive requirement. */ + /* Update %INC. Assume success here to prevent recursive requirement. */ /* name is never assigned to again, so len is still strlen(name) */ /* Check whether a hook in @INC has already filled %INC */ if (!hook_sv) { @@ -4023,6 +4237,8 @@ PP(pp_require) unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } + /* Now parse the file */ + old_savestack_ix = PL_savestack_ix; SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tryname); @@ -4043,10 +4259,9 @@ PP(pp_require) } /* switch to eval mode */ - PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name); - cx->blk_oldsaveix = old_savestack_ix; - cx->blk_eval.retop = PL_op->op_next; + assert(!CATCH_GET); + cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix); + cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0)); SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 0); @@ -4054,15 +4269,34 @@ PP(pp_require) PUTBACK; if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL)) - op = DOCATCH(PL_eval_start); + op = PL_eval_start; else op = PL_op->op_next; - LOADED_FILE_PROBE(unixname); + PERL_DTRACE_PROBE_FILE_LOADED(unixname); return op; } + +/* also used for: pp_dofile() */ + +PP(pp_require) +{ + RUN_PP_CATCHABLY(Perl_pp_require); + + { + dSP; + SV *sv = POPs; + SvGETMAGIC(sv); + PUTBACK; + return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) + ? S_require_version(aTHX_ sv) + : S_require_file(aTHX_ sv); + } +} + + /* This is a op added to hold the hints hash for pp_entereval. The hash can be modified by the code being eval'ed, so we return a copy instead. */ @@ -4080,18 +4314,28 @@ PP(pp_entereval) dSP; PERL_CONTEXT *cx; SV *sv; - const I32 gimme = GIMME_V; - const U32 was = PL_breakable_sub_gen; + U8 gimme; + U32 was; char tbuf[TYPE_DIGITS(long) + 12]; - bool saved_delete = FALSE; - char *tmpbuf = tbuf; + bool saved_delete; + char *tmpbuf; STRLEN len; CV* runcv; - U32 seq, lex_flags = 0; - HV *saved_hh = NULL; - const bool bytes = PL_op->op_private & OPpEVAL_BYTES; + U32 seq, lex_flags; + HV *saved_hh; + bool bytes; I32 old_savestack_ix; + RUN_PP_CATCHABLY(Perl_pp_entereval); + + gimme = GIMME_V; + was = PL_breakable_sub_gen; + saved_delete = FALSE; + tmpbuf = tbuf; + lex_flags = 0; + saved_hh = NULL; + bytes = PL_op->op_private & OPpEVAL_BYTES; + if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } @@ -4140,7 +4384,7 @@ PP(pp_entereval) if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV * const temp_sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]", + Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]", (unsigned long)++PL_evalseq, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); tmpbuf = SvPVX(temp_sv); @@ -4159,10 +4403,9 @@ PP(pp_entereval) * to do the dirty work for us */ runcv = find_runcv(&seq); - PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); - PUSHEVAL(cx, 0); - cx->blk_oldsaveix = old_savestack_ix; - cx->blk_eval.retop = PL_op->op_next; + assert(!CATCH_GET); + cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix); + cx_pusheval(cx, PL_op->op_next, NULL); /* prepare to compile string */ @@ -4190,7 +4433,7 @@ PP(pp_entereval) char *const safestr = savepvn(tmpbuf, len); SAVEDELETE(PL_defstash, safestr, len); } - return DOCATCH(PL_eval_start); + return PL_eval_start; } else { /* We have already left the scope set up earlier thanks to the LEAVE in doeval_compile(). */ @@ -4205,16 +4448,18 @@ PP(pp_entereval) } } + +/* also tail-called by pp_return */ + PP(pp_leaveeval) { SV **oldsp; - I32 gimme; + U8 gimme; PERL_CONTEXT *cx; OP *retop; - SV *namesv = NULL; + int failed; CV *evalcv; - /* grab this value before POPEVAL restores old PL_in_eval */ - bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); + bool keep; PERL_ASYNC_CHECK(); @@ -4225,19 +4470,20 @@ PP(pp_leaveeval) gimme = cx->blk_gimme; /* did require return a false value? */ - if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE - && !(gimme == G_SCALAR - ? SvTRUE(*PL_stack_sp) - : PL_stack_sp > oldsp) - ) - namesv = cx->blk_eval.old_namesv; + failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE + && !(gimme == G_SCALAR + ? SvTRUE_NN(*PL_stack_sp) + : PL_stack_sp > oldsp); - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 0); - /* the POPEVAL does a leavescope, which frees the optree associated + /* the cx_popeval does a leavescope, which frees the optree associated * with eval, which if it frees the nextstate associated with * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a * regex when running under 'use re Debug' because it needs PL_curcop @@ -4245,23 +4491,17 @@ PP(pp_leaveeval) */ PL_curcop = cx->blk_oldcop; - CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); + /* grab this value before cx_popeval restores the old PL_in_eval */ + keep = cBOOL(PL_in_eval & EVAL_KEEPERR); retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; - CX_POP(cx); - #ifdef DEBUGGING assert(CvDEPTH(evalcv) == 1); #endif CvDEPTH(evalcv) = 0; - if (namesv) { /* require returned false */ - /* Unassume the success we assumed earlier. */ - S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE); - NOT_REACHED; /* NOTREACHED */ - } + /* pop the CXt_EVAL, and if a require failed, croak */ + S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed); if (!keep) CLEAR_ERRSV(); @@ -4278,22 +4518,22 @@ Perl_delete_eval_scope(pTHX) cx = CX_CUR(); CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); + cx_popeval(cx); + cx_popblock(cx); CX_POP(cx); } /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was also needed by Perl_fold_constants. */ -PERL_CONTEXT * -Perl_create_eval_scope(pTHX_ U32 flags) +void +Perl_create_eval_scope(pTHX_ OP *retop, U32 flags) { PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); - PUSHEVAL(cx, 0); - cx->blk_oldsaveix = PL_savestack_ix; + cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme, + PL_stack_sp, PL_savestack_ix); + cx_pusheval(cx, retop, NULL); PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -4303,20 +4543,24 @@ Perl_create_eval_scope(pTHX_ U32 flags) if (flags & G_FAKINGEVAL) { PL_eval_root = PL_op; /* Only needed so that goto works right. */ } - return cx; } PP(pp_entertry) { - PERL_CONTEXT * const cx = create_eval_scope(0); - cx->blk_eval.retop = cLOGOP->op_other->op_next; - return DOCATCH(PL_op->op_next); + RUN_PP_CATCHABLY(Perl_pp_entertry); + + assert(!CATCH_GET); + create_eval_scope(cLOGOP->op_other->op_next, 0); + return PL_op->op_next; } + +/* also tail-called by pp_return */ + PP(pp_leavetry) { SV **oldsp; - I32 gimme; + U8 gimme; PERL_CONTEXT *cx; OP *retop; @@ -4327,13 +4571,16 @@ PP(pp_leavetry) oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); - POPEVAL(cx); - POPBLOCK(cx); + cx_popeval(cx); + cx_popblock(cx); retop = cx->blk_eval.retop; CX_POP(cx); @@ -4345,15 +4592,15 @@ PP(pp_entergiven) { dSP; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; SV *origsv = DEFSV; SV *newsv = POPs; assert(!PL_op->op_targ); /* used to be set for lexical $_ */ GvSV(PL_defgv) = SvREFCNT_inc(newsv); - PUSHBLOCK(cx, CXt_GIVEN, SP); - PUSHGIVEN(cx, origsv); + cx = cx_pushblock(CXt_GIVEN, gimme, SP, PL_savestack_ix); + cx_pushgiven(cx, origsv); RETURN; } @@ -4361,7 +4608,7 @@ PP(pp_entergiven) PP(pp_leavegiven) { PERL_CONTEXT *cx; - I32 gimme; + U8 gimme; SV **oldsp; PERL_UNUSED_CONTEXT; @@ -4376,552 +4623,39 @@ PP(pp_leavegiven) leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); - POPGIVEN(cx); - POPBLOCK(cx); + cx_popgiven(cx); + cx_popblock(cx); CX_POP(cx); return NORMAL; } -/* Helper routines used by pp_smartmatch */ -STATIC PMOP * -S_make_matcher(pTHX_ REGEXP *re) -{ - PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); - - PERL_ARGS_ASSERT_MAKE_MATCHER; - - PM_SETRE(matcher, ReREFCNT_inc(re)); - - SAVEFREEOP((OP *) matcher); - ENTER_with_name("matcher"); SAVETMPS; - SAVEOP(); - return matcher; -} - -STATIC bool -S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) -{ - dSP; - bool result; - - PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; - - PL_op = (OP *) matcher; - XPUSHs(sv); - PUTBACK; - (void) Perl_pp_match(aTHX); - SPAGAIN; - result = SvTRUEx(POPs); - PUTBACK; - - return result; -} - -STATIC void -S_destroy_matcher(pTHX_ PMOP *matcher) -{ - PERL_ARGS_ASSERT_DESTROY_MATCHER; - PERL_UNUSED_ARG(matcher); - - FREETMPS; - LEAVE_with_name("matcher"); -} - -/* Do a smart match */ PP(pp_smartmatch) { - DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); - return do_smartmatch(NULL, NULL, 0); -} - -/* This version of do_smartmatch() implements the - * table of smart matches that is found in perlsyn. - */ -STATIC OP * -S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) -{ dSP; - - bool object_on_left = FALSE; - SV *e = TOPs; /* e is for 'expression' */ - SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ - - /* Take care only to invoke mg_get() once for each argument. - * Currently we do this by copying the SV if it's magical. */ - if (d) { - if (!copied && SvGMAGICAL(d)) - d = sv_mortalcopy(d); - } - else - d = &PL_sv_undef; - - assert(e); - if (SvGMAGICAL(e)) - e = sv_mortalcopy(e); + SV *right = POPs; + SV *left = TOPs; + SV *result; - /* First of all, handle overload magic of the rightmost argument */ - if (SvAMAGIC(e)) { - SV * tmpsv; - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); - DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); - - tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); - if (tmpsv) { - SPAGAIN; - (void)POPs; - SETs(tmpsv); - RETURN; - } - DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); - } - - SP -= 2; /* Pop the values */ PUTBACK; - - /* ~~ undef */ - if (!SvOK(e)) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); - if (SvOK(d)) - RETPUSHNO; - else - RETPUSHYES; - } - - 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 (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) - object_on_left = TRUE; - - /* ~~ sub */ - if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { - I32 c; - if (object_on_left) { - goto sm_any_sub; /* Treat objects like scalars */ - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - /* Test sub truth for each key */ - HE *he; - bool andedresults = TRUE; - HV *hv = (HV*) SvRV(d); - I32 numkeys = hv_iterinit(hv); - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); - if (numkeys == 0) - RETPUSHYES; - while ( (he = hv_iternext(hv)) ) { - DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); - ENTER_with_name("smartmatch_hash_key_test"); - SAVETMPS; - PUSHMARK(SP); - PUSHs(hv_iterkeysv(he)); - PUTBACK; - c = call_sv(e, G_SCALAR); - SPAGAIN; - if (c == 0) - andedresults = FALSE; - else - andedresults = SvTRUEx(POPs) && andedresults; - FREETMPS; - LEAVE_with_name("smartmatch_hash_key_test"); - } - if (andedresults) - RETPUSHYES; - else - RETPUSHNO; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - /* Test sub truth for each element */ - SSize_t i; - bool andedresults = TRUE; - AV *av = (AV*) SvRV(d); - const I32 len = av_tindex(av); - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); - if (len == -1) - RETPUSHYES; - for (i = 0; i <= len; ++i) { - SV * const * const svp = av_fetch(av, i, FALSE); - DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); - ENTER_with_name("smartmatch_array_elem_test"); - SAVETMPS; - PUSHMARK(SP); - if (svp) - PUSHs(*svp); - PUTBACK; - c = call_sv(e, G_SCALAR); - SPAGAIN; - if (c == 0) - andedresults = FALSE; - else - andedresults = SvTRUEx(POPs) && andedresults; - FREETMPS; - LEAVE_with_name("smartmatch_array_elem_test"); - } - if (andedresults) - RETPUSHYES; - else - RETPUSHNO; - } - else { - sm_any_sub: - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); - ENTER_with_name("smartmatch_coderef"); - SAVETMPS; - PUSHMARK(SP); - PUSHs(d); - PUTBACK; - c = call_sv(e, G_SCALAR); - SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_no); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - FREETMPS; - LEAVE_with_name("smartmatch_coderef"); - RETURN; - } - } - /* ~~ %hash */ - else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { - if (object_on_left) { - goto sm_any_hash; /* Treat objects like scalars */ - } - else if (!SvOK(d)) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); - RETPUSHNO; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - /* Check that the key-sets are identical */ - HE *he; - HV *other_hv = MUTABLE_HV(SvRV(d)); - bool tied; - bool other_tied; - U32 this_key_count = 0, - other_key_count = 0; - HV *hv = MUTABLE_HV(SvRV(e)); - - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); - /* Tied hashes don't know how many keys they have. */ - tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied)); - other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)); - if (!tied ) { - if(other_tied) { - /* swap HV sides */ - HV * const temp = other_hv; - other_hv = hv; - hv = temp; - tied = TRUE; - other_tied = FALSE; - } - else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) - RETPUSHNO; - } - - /* The hashes have the same number of keys, so it suffices - to check that one is a subset of the other. */ - (void) hv_iterinit(hv); - while ( (he = hv_iternext(hv)) ) { - SV *key = hv_iterkeysv(he); - - DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); - ++ this_key_count; - - if(!hv_exists_ent(other_hv, key, 0)) { - (void) hv_iterinit(hv); /* reset iterator */ - RETPUSHNO; - } - } - - if (other_tied) { - (void) hv_iterinit(other_hv); - while ( hv_iternext(other_hv) ) - ++other_key_count; - } - else - other_key_count = HvUSEDKEYS(other_hv); - - if (this_key_count != other_key_count) - RETPUSHNO; - else - RETPUSHYES; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - AV * const other_av = MUTABLE_AV(SvRV(d)); - const SSize_t other_len = av_tindex(other_av) + 1; - SSize_t i; - HV *hv = MUTABLE_HV(SvRV(e)); - - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); - for (i = 0; i < other_len; ++i) { - SV ** const svp = av_fetch(other_av, i, FALSE); - DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); - if (svp) { /* ??? When can this not happen? */ - if (hv_exists_ent(hv, *svp, 0)) - RETPUSHYES; - } - } - RETPUSHNO; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); - sm_regex_hash: - { - PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); - HE *he; - HV *hv = MUTABLE_HV(SvRV(e)); - - (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; - } - } - else { - sm_any_hash: - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); - if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) - RETPUSHYES; - else - RETPUSHNO; - } - } - /* ~~ @array */ - else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { - if (object_on_left) { - goto sm_any_array; /* Treat objects like scalars */ - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - AV * const other_av = MUTABLE_AV(SvRV(e)); - const SSize_t other_len = av_tindex(other_av) + 1; - SSize_t i; - - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); - for (i = 0; i < other_len; ++i) { - SV ** const svp = av_fetch(other_av, i, FALSE); - - DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); - if (svp) { /* ??? When can this not happen? */ - if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) - RETPUSHYES; - } - } - RETPUSHNO; - } - if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - AV *other_av = MUTABLE_AV(SvRV(d)); - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); - if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av)) - RETPUSHNO; - else { - SSize_t i; - const SSize_t other_len = av_tindex(other_av); - - if (NULL == seen_this) { - seen_this = newHV(); - (void) sv_2mortal(MUTABLE_SV(seen_this)); - } - if (NULL == seen_other) { - seen_other = newHV(); - (void) sv_2mortal(MUTABLE_SV(seen_other)); - } - for(i = 0; i <= other_len; ++i) { - SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); - SV * const * const other_elem = av_fetch(other_av, i, FALSE); - - if (!this_elem || !other_elem) { - if ((this_elem && SvOK(*this_elem)) - || (other_elem && SvOK(*other_elem))) - RETPUSHNO; - } - else if (hv_exists_ent(seen_this, - sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || - hv_exists_ent(seen_other, - sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) - { - if (*this_elem != *other_elem) - RETPUSHNO; - } - else { - (void)hv_store_ent(seen_this, - sv_2mortal(newSViv(PTR2IV(*this_elem))), - &PL_sv_undef, 0); - (void)hv_store_ent(seen_other, - sv_2mortal(newSViv(PTR2IV(*other_elem))), - &PL_sv_undef, 0); - PUSHs(*other_elem); - PUSHs(*this_elem); - - PUTBACK; - DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); - (void) do_smartmatch(seen_this, seen_other, 0); - SPAGAIN; - DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); - - if (!SvTRUEx(POPs)) - RETPUSHNO; - } - } - RETPUSHYES; - } - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); - sm_regex_array: - { - PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); - const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); - SSize_t i; - - 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; - } - } - else if (!SvOK(d)) { - /* undef ~~ array */ - const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); - SSize_t i; - - DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); - 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 for undef element...\n")); - if (!svp || !SvOK(*svp)) - RETPUSHYES; - } - RETPUSHNO; - } - else { - sm_any_array: - { - SSize_t i; - const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e))); - - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); - for (i = 0; i <= this_len; ++i) { - SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); - if (!svp) - continue; - - PUSHs(d); - PUSHs(*svp); - PUTBACK; - /* infinite recursion isn't supposed to happen here */ - DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); - (void) do_smartmatch(NULL, NULL, 1); - SPAGAIN; - DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); - if (SvTRUEx(POPs)) - RETPUSHYES; - } - RETPUSHNO; - } - } - } - /* ~~ qr// */ - else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { - if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - SV *t = d; d = e; e = t; - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); - goto sm_regex_hash; - } - else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - SV *t = d; d = e; e = t; - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); - goto sm_regex_array; - } - else { - PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); - bool result; - - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); - PUTBACK; - result = matcher_matches_sv(matcher, d); - SPAGAIN; - PUSHs(result ? &PL_sv_yes : &PL_sv_no); - destroy_matcher(matcher); - RETURN; - } - } - /* ~~ scalar */ - /* See if there is overload magic on left */ - else if (object_on_left && SvAMAGIC(d)) { - SV *tmpsv; - DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); - DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); - PUSHs(d); PUSHs(e); - PUTBACK; - tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); - if (tmpsv) { - SPAGAIN; - (void)POPs; - SETs(tmpsv); - RETURN; - } - SP -= 2; - DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); - goto sm_any_scalar; - } - else if (!SvOK(d)) { - /* undef ~~ scalar ; we already know that the scalar is SvOK */ - DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); - RETPUSHNO; - } - else - sm_any_scalar: - if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { - DEBUG_M(if (SvNIOK(e)) - Perl_deb(aTHX_ " applying rule Any-Num\n"); - else - Perl_deb(aTHX_ " applying rule Num-numish\n"); - ); - /* numeric comparison */ - PUSHs(d); PUSHs(e); - PUTBACK; - if (CopHINTS_get(PL_curcop) & HINT_INTEGER) - (void) Perl_pp_i_eq(aTHX); - else - (void) Perl_pp_eq(aTHX); + if (SvGMAGICAL(left)) + left = sv_mortalcopy(left); + if (SvGMAGICAL(right)) + right = sv_mortalcopy(right); + if (SvAMAGIC(right) && + (result = amagic_call(left, right, smart_amg, AMGf_noleft))) { SPAGAIN; - if (SvTRUEx(POPs)) - RETPUSHYES; - else - RETPUSHNO; + SETs(boolSV(SvTRUE_NN(result))); + return NORMAL; } - - /* As a last resort, use string comparison */ - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); - PUSHs(d); PUSHs(e); - PUTBACK; - return Perl_pp_seq(aTHX); + Perl_croak(aTHX_ "Cannot smart match without a matcher object"); } PP(pp_enterwhen) { dSP; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; /* This is essentially an optimization: if the match fails, we don't want to push a context and then @@ -4929,11 +4663,11 @@ PP(pp_enterwhen) to the op that follows the leavewhen. RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ - if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) + if (!SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other->op_next); - PUSHBLOCK(cx, CXt_WHEN, SP); - PUSHWHEN(cx); + cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix); + cx_pushwhen(cx); RETURN; } @@ -4942,7 +4676,7 @@ PP(pp_leavewhen) { I32 cxix; PERL_CONTEXT *cx; - I32 gimme; + U8 gimme; SV **oldsp; cx = CX_CUR(); @@ -4951,9 +4685,7 @@ PP(pp_leavewhen) cxix = dopoptogivenfor(cxstack_ix); if (cxix < 0) - /* diag_listed_as: Can't "when" outside a topicalizer */ - DIE(aTHX_ "Can't \"%s\" outside a topicalizer", - PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); + DIE(aTHX_ "Can't \"when\" outside a topicalizer"); oldsp = PL_stack_base + cx->blk_oldsp; if (gimme == G_VOID) @@ -4971,14 +4703,14 @@ PP(pp_leavewhen) /* emulate pp_next. Note that any stack(s) cleanup will be * done by the pp_unstack which op_nextop should point to */ cx = CX_CUR(); - TOPBLOCK(cx); + cx_topblock(cx); PL_curcop = cx->blk_oldcop; return cx->blk_loop.my_op->op_nextop; } else { PERL_ASYNC_CHECK(); - assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN); - return cx->blk_givwhen.leave_op; + assert(cx->blk_loop.my_op->op_nextop->op_type == OP_LEAVEGIVEN); + return cx->blk_loop.my_op->op_nextop; } } @@ -4999,8 +4731,8 @@ PP(pp_continue) assert(CxTYPE(cx) == CXt_WHEN); PL_stack_sp = PL_stack_base + cx->blk_oldsp; CX_LEAVE_SCOPE(cx); - POPWHEN(cx); - POPBLOCK(cx); + cx_popwhen(cx); + cx_popblock(cx); nextop = cx->blk_givwhen.leave_op->op_next; CX_POP(cx); @@ -5027,7 +4759,7 @@ PP(pp_break) cx = CX_CUR(); PL_stack_sp = PL_stack_base + cx->blk_oldsp; - return cx->blk_givwhen.leave_op; + return cx->blk_loop.my_op->op_nextop; } static MAGIC * @@ -5068,7 +4800,7 @@ S_doparseform(pTHX_ SV *sv) SV *old = mg->mg_obj; if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) && len == SvCUR(old) - && strnEQ(SvPVX(old), SvPVX(sv), len) + && strnEQ(SvPVX(old), s, len) ) { DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); return mg; @@ -5129,7 +4861,8 @@ S_doparseform(pTHX_ SV *sv) if (s < send) { skipspaces = 0; continue; - } /* else FALL THROUGH */ + } + /* FALLTHROUGH */ case '\n': arg = s - base; skipspaces++; @@ -5397,7 +5130,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) DEFSV_set(upstream); PUSHMARK(SP); - mPUSHi(0); + PUSHs(&PL_sv_zero); if (filter_state) { PUSHs(filter_state); }