#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))
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
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
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,
TAINT_NOT;
CX_LEAVE_SCOPE(cx);
- POPSUBST(cx);
+ CX_POPSUBST(cx);
CX_POP(cx);
PERL_ASYNC_CHECK();
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);
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 */
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++;
SvSETMAGIC(sv);
break;
}
+ /* FALLTHROUGH */
case FF_LINESNGL: /* process ^* */
chopspace = 0;
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;
*t++ = ' ';
}
s1 = t - 3;
- if (strnEQ(s1," ",3)) {
+ if (strBEGINs(s1," ")) {
while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
s1--;
}
}
}
+/* also used for: pp_mapstart() */
PP(pp_grepstart)
{
dSP;
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;
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;
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;
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);
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
- sv_setpvs(TARG, "");
+ SvPVCLEAR(TARG);
SETs(targ);
RETURN;
}
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))
}
}
else {
- flop = SvTRUE(sv);
+ flop = SvTRUE_NN(sv);
}
if (flop) {
-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);
return 0;
}
-/* only used by PUSHSUB */
+/* only used by cx_pushsub() */
I32
Perl_was_lvalue_sub(pTHX)
{
/* 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.
*/
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--;
}
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
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.
* 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));
}
}
if (cxix >= 0) {
- SV *namesv = NULL;
PERL_CONTEXT *cx;
SV **oldsp;
- I32 gimme;
+ U8 gimme;
JMPENV *restartjmpenv;
OP *restartop;
*++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);
PP(pp_xor)
{
dSP; dPOPTOPssrl;
- if (SvTRUE(left) != SvTRUE(right))
+ if (SvTRUE_NN(left) != SvTRUE_NN(right))
RETSETYES;
else
RETSETNO;
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;
}
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
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));
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]);
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));
{
dSP;
PERL_CONTEXT *cx;
- const I32 gimme = G_ARRAY;
+ const U8 gimme = G_ARRAY;
GV * const gv = PL_DBgv;
CV * cv = NULL;
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));
}
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;
PL_op->op_private & OPpLVALUE ? 3 : 1);
CX_LEAVE_SCOPE(cx);
- POPBASICBLK(cx);
- POPBLOCK(cx);
+ cx_popblock(cx);
CX_POP(cx);
return NORMAL;
{
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;
/* 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
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;
*
* 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;
}
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);
}
/* 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;
/* find the enclosing loop or labelled loop and dounwind() back to it. */
-PERL_CONTEXT *
+static PERL_CONTEXT *
S_unwind_loop(pTHX)
{
I32 cxix;
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)
/* 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);
{
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;
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;
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");
}
dounwind(cxix);
}
cx = CX_CUR();
- TOPBLOCK(cx);
+ cx_topblock(cx);
SPAGAIN;
/* protect @_ during save stack unwind. */
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))[
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");
SP += items;
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
/* Restore old @_ */
- POP_SAVEARRAY(cx);
+ CX_POP_SAVEARRAY(cx);
}
retop = cx->blk_sub.retop;
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);
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);
OP *gotoprobe = NULL;
bool leaving_eval = FALSE;
bool in_block = FALSE;
+ bool pseudo_block = FALSE;
PERL_CONTEXT *last_eval_cx = NULL;
/* find label */
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");
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
DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
dounwind(ix);
cx = CX_CUR();
- TOPBLOCK(cx);
+ cx_topblock(cx);
}
/* push wanted frames */
=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;
return cv;
case FIND_RUNCV_level_eq:
if (level++ != arg) continue;
- /* GERONIMO! */
+ /* FALLTHROUGH */
default:
return cv;
}
*/
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;
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);
}
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
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;
}
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");
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)
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
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;
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)
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;
# 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)
{
}
-/* 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<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
+ * 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;
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;
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);
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;
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;
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;
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;
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 =
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] == ':'))
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
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) {
*/
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);
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<require
+ * Foo::Bar>), 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?)");
}
}
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) {
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);
}
/* 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);
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. */
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));
}
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);
* 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 */
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(). */
}
}
+
+/* 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();
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
*/
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();
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)
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;
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);
{
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;
}
PP(pp_leavegiven)
{
PERL_CONTEXT *cx;
- I32 gimme;
+ U8 gimme;
SV **oldsp;
PERL_UNUSED_CONTEXT;
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
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;
}
{
I32 cxix;
PERL_CONTEXT *cx;
- I32 gimme;
+ U8 gimme;
SV **oldsp;
cx = CX_CUR();
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)
/* 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;
}
}
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);
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 *
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;
if (s < send) {
skipspaces = 0;
continue;
- } /* else FALL THROUGH */
+ }
+ /* FALLTHROUGH */
case '\n':
arg = s - base;
skipspaces++;
DEFSV_set(upstream);
PUSHMARK(SP);
- mPUSHi(0);
+ PUSHs(&PL_sv_zero);
if (filter_state) {
PUSHs(filter_state);
}
https://perl5.git.perl.org / perl5.git / blobdiff