#include "EXTERN.h"
#define PERL_IN_PP_CTL_C
#include "perl.h"
+#include "feature.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 dopopto_cursub() \
+ (PL_curstackinfo->si_cxsubix >= 0 \
+ ? PL_curstackinfo->si_cxsubix \
+ : dopoptosub_at(cxstack, cxstack_ix))
#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
}
else {
- cxix = dopoptosub(cxstack_ix);
+ cxix = dopopto_cursub();
if (cxix < 0)
RETPUSHUNDEF;
cx = &cxstack[cxix];
/* handle the empty pattern */
if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
if (PL_curpm == PL_reg_curpm) {
- if (PL_curpm_under) {
- if (PL_curpm_under == PL_reg_curpm) {
- Perl_croak(aTHX_ "Infinite recursion via empty pattern");
- } else {
- pm = PL_curpm_under;
- }
+ if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
+ Perl_croak(aTHX_ "Infinite recursion via empty pattern");
}
- } else {
- pm = PL_curpm;
}
}
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,
(void)SvPOK_only_UTF8(targ);
}
- /* update the taint state of various various variables in
+ /* update the taint state of various variables in
* preparation for final exit.
* See "how taint works" above pp_subst() */
if (TAINTING_get) {
cBOOL(cx->sb_rxtainted &
(SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
);
+
+ /* sv_magic(), when adding magic (e.g.taint magic), also
+ * recalculates any pos() magic, converting any byte offset
+ * to utf8 offset. Make sure pos() is reset before this
+ * happens rather than using the now invalid value (since
+ * we've just replaced targ's pvx buffer with the
+ * potentially shorter dstr buffer). Normally (i.e. in
+ * non-taint cases), pos() gets removed a few lines later
+ * with the SvSETMAGIC().
+ */
+ {
+ MAGIC *mg;
+ mg = mg_find_mglob(targ);
+ if (mg) {
+ MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
+ }
+ }
+
SvTAINT(TARG);
}
/* PL_tainted must be correctly set for this mg_set */
}
if (old != rx)
(void)ReREFCNT_inc(rx);
- /* update the taint state of various various variables in preparation
+ /* update the taint state of various variables in preparation
* for calling the code block.
* See "how taint works" above pp_subst() */
if (TAINTING_get) {
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? */
+ 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 */
fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
formsv = newformsv;
- copied_form = true;
+ copied_form = TRUE;
}
if (chopspace) {
while (isSPACE(*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;
* for safety */
grow = linemax;
while (linemark--)
- s += UTF8SKIP(s);
+ s += UTF8_SAFE_SKIP(s,
+ (U8 *) SvEND(PL_formtarget));
linemark = s - (U8*)SvPVX(PL_formtarget);
}
/* Easy. They agree. */
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
#ifdef USE_QUADMATH
{
- const char* qfmt = quadmath_format_single(fmt);
int len;
- if (!qfmt)
+ if (!quadmath_format_valid(fmt))
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
- len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
+ len = quadmath_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
if (len == -1)
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
- if (qfmt != fmt)
- Safefree(fmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
}
#else
/* we generate fmt ourselves so it is safe */
- GCC_DIAG_IGNORE(-Wformat-nonliteral);
+ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
- GCC_DIAG_RESTORE;
+ GCC_DIAG_RESTORE_STMT;
#endif
PERL_MY_SNPRINTF_POST_GUARD(len, max);
RESTORE_LC_NUMERIC();
*t++ = ' ';
}
s1 = t - 3;
- if (strnEQ(s1," ",3)) {
+ if (strBEGINs(s1," ")) {
while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
s1--;
}
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_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);
}
/* This code tries to decide if "$left .. $right" should use the
- magical string increment, or if the range is numeric (we make
- an exception for .."0" [#18165]). AMS 20021031. */
+ magical string increment, or if the range is numeric. Initially,
+ an exception was made for *any* string beginning with "0" (see
+ [#18165], AMS 20021031), but now that is only applied when the
+ string's length is also >1 - see the rules now documented in
+ perlop [#133695] */
#define RANGE_IS_NUMERIC(left,right) ( \
SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
(((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
- looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
+ looks_like_number(left)) && SvPOKp(left) \
+ && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
&& (!SvOK(right) || looks_like_number(right))))
PP(pp_flop)
if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
(SvOK(right) && (SvIOK(right)
? SvIsUV(right) && SvUV(right) > IV_MAX
- : SvNV_nomg(right) > IV_MAX)))
+ : SvNV_nomg(right) > (NV) IV_MAX)))
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV_nomg(left);
j = SvIV_nomg(right);
}
}
else {
- flop = SvTRUE(sv);
+ flop = SvTRUE_NN(sv);
}
if (flop) {
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
+/* note that this function has mostly been superseded by Perl_gimme_V */
+
U8
Perl_block_gimme(pTHX)
{
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
U8 gimme;
if (cxix < 0)
return G_VOID;
I32
Perl_is_lvalue_sub(pTHX)
{
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
assert(cxix >= 0); /* We should only be called from inside subs */
if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
if (in_eval) {
I32 cxix;
- exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
+ /* 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.
+ */
+ if (PL_phase == PERL_PHASE_DESTRUCT) {
+ exceptsv = sv_mortalcopy(exceptsv);
+ } else {
+ exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
+ }
/*
* Historically, perl used to set ERRSV ($@) early in the die
* perls 5.13.{1..7} which had late setting of $@ without this
* early-setting hack.
*/
- if (!(in_eval & EVAL_KEEPERR))
+ if (!(in_eval & EVAL_KEEPERR)) {
+ /* remove any read-only/magic from the SV, so we don't
+ get infinite recursion when setting ERRSV */
+ SANE_ERRSV();
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,
restartjmpenv = cx->blk_eval.cur_top_env;
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
*/
S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
- if (!(in_eval & EVAL_KEEPERR))
+ if (!(in_eval & EVAL_KEEPERR)) {
+ SANE_ERRSV();
sv_setsv(ERRSV, exceptsv);
+ }
PL_restartjmpenv = restartjmpenv;
PL_restartop = restartop;
JMPENV_JUMP(3);
PP(pp_xor)
{
dSP; dPOPTOPssrl;
- if (SvTRUE(left) != SvTRUE(right))
+ if (SvTRUE_NN(left) != SvTRUE_NN(right))
RETSETYES;
else
RETSETNO;
/*
-=head1 CV Manipulation Functions
+=for apidoc_section $CV
=for apidoc caller_cx
const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
- I32 cxix = dopoptosub(cxstack_ix);
+ I32 cxix = dopopto_cursub();
const PERL_CONTEXT *cx;
const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
}
else {
PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
- mPUSHi(0);
+ PUSHs(&PL_sv_zero);
}
gimme = cx->blk_gimme;
if (gimme == G_VOID)
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; dMARK;
PERL_CONTEXT *cx;
- const I32 cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopopto_cursub();
assert(cxstack_ix >= 0);
if (cxix < cxstack_ix) {
return redo_op;
}
+#define UNENTERABLE (OP *)1
+#define GOTO_DEPTH 64
+
STATIC OP *
S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
{
o->op_type == OP_SCOPE ||
o->op_type == OP_LEAVELOOP ||
o->op_type == OP_LEAVESUB ||
- o->op_type == OP_LEAVETRY)
+ o->op_type == OP_LEAVETRY ||
+ o->op_type == OP_LEAVEGIVEN)
{
*ops++ = cUNOPo->op_first;
- if (ops >= oplimit)
- Perl_croak(aTHX_ "%s", too_deep);
}
+ else if (oplimit - opstack < GOTO_DEPTH) {
+ if (o->op_flags & OPf_KIDS
+ && cUNOPo->op_first->op_type == OP_PUSHMARK) {
+ *ops++ = UNENTERABLE;
+ }
+ else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
+ && OP_CLASS(o) != OA_LOGOP
+ && o->op_type != OP_LINESEQ
+ && o->op_type != OP_SREFGEN
+ && o->op_type != OP_ENTEREVAL
+ && o->op_type != OP_GLOB
+ && o->op_type != OP_RV2CV) {
+ OP * const kid = cUNOPo->op_first;
+ if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
+ *ops++ = UNENTERABLE;
+ }
+ }
+ if (ops >= oplimit)
+ Perl_croak(aTHX_ "%s", too_deep);
*ops = 0;
if (o->op_flags & OPf_KIDS) {
OP *kid;
+ OP * const kid1 = cUNOPo->op_first;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
}
}
for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+ bool first_kid_of_binary = FALSE;
if (kid == PL_lastgotoprobe)
continue;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
if (ops == opstack)
*ops++ = kid;
- else if (ops[-1]->op_type == OP_NEXTSTATE ||
- ops[-1]->op_type == OP_DBSTATE)
+ else if (ops[-1] != UNENTERABLE
+ && (ops[-1]->op_type == OP_NEXTSTATE ||
+ ops[-1]->op_type == OP_DBSTATE))
ops[-1] = kid;
else
*ops++ = kid;
}
+ if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
+ first_kid_of_binary = TRUE;
+ ops--;
+ }
if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
return o;
+ if (first_kid_of_binary)
+ *ops++ = UNENTERABLE;
}
}
*ops = 0;
}
+static void
+S_check_op_type(pTHX_ OP * const o)
+{
+ /* Eventually we may want to stack the needed arguments
+ * for each op. For now, we punt on the hard ones. */
+ /* XXX This comment seems to me like wishful thinking. --sprout */
+ if (o == UNENTERABLE)
+ Perl_croak(aTHX_
+ "Can't \"goto\" into a binary or list expression");
+ if (o->op_type == OP_ENTERITER)
+ Perl_croak(aTHX_
+ "Can't \"goto\" into the middle of a foreach loop");
+ if (o->op_type == OP_ENTERGIVEN)
+ Perl_croak(aTHX_
+ "Can't \"goto\" into a \"given\" block");
+}
+
/* also used for: pp_dump() */
PP(pp_goto)
{
- dVAR; dSP;
+ dSP;
OP *retop = NULL;
I32 ix;
PERL_CONTEXT *cx;
-#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
const char *label = NULL;
STRLEN label_len = 0;
DIE(aTHX_ "Goto undefined subroutine");
}
- cxix = dopoptosub(cxstack_ix);
+ cxix = dopopto_cursub();
if (cxix < 0) {
DIE(aTHX_ "Can't goto subroutine outside a subroutine");
}
* this is a cx_popblock(), less all the stuff we already did
* for cx_topblock() earlier */
PL_curcop = cx->blk_oldcop;
+ /* this is cx_popsub, less all the stuff we already did */
+ PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
+
CX_POP(cx);
/* Push a mark for the start of arglist */
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)
if (leaving_eval && *enterops && enterops[1]) {
I32 i;
for (i = 1; enterops[i]; i++)
- if (enterops[i]->op_type == OP_ENTERITER)
- DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
+ S_check_op_type(aTHX_ enterops[i]);
}
if (*enterops && enterops[1]) {
- I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ I32 i = enterops[1] != UNENTERABLE
+ && enterops[1]->op_type == OP_ENTER && in_block
+ ? 2
+ : 1;
if (enterops[i])
deprecate("\"goto\" to jump into a construct");
}
if (*enterops && enterops[1]) {
OP * const oldop = PL_op;
- ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ ix = enterops[1] != UNENTERABLE
+ && enterops[1]->op_type == OP_ENTER && in_block
+ ? 2
+ : 1;
for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
- /* Eventually we may want to stack the needed arguments
- * for each op. For now, we punt on the hard ones. */
- if (PL_op->op_type == OP_ENTERITER)
- DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
+ S_check_op_type(aTHX_ PL_op);
+ DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
+ OP_NAME(PL_op)));
PL_op->op_ppaddr(aTHX);
}
PL_op = oldop;
=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;
}
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);
SAVEHINTS();
if (clear_hints) {
- PL_hints = 0;
+ PL_hints = HINTS_DEFAULT;
hv_clear(GvHV(PL_hintgv));
+ CLEARFEATUREBITS();
}
else {
PL_hints = saveop->op_private & OPpEVAL_COPHH
/* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
SvREFCNT_dec(GvHV(PL_hintgv));
GvHV(PL_hintgv) = hh;
+ FETCHFEATUREBITSHH(hh);
}
}
SAVECOMPILEWARNINGS();
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)
{
static OP *
S_require_version(pTHX_ SV *sv)
{
- dVAR; dSP;
+ dSP;
sv = sv_2mortal(new_version(sv));
if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
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 */
+ || av_count(lav) > 2 /* FP with > 3 digits */
|| strstr(SvPVX(pv),".0") /* FP with leading 0 */
) {
DIE(aTHX_ "Perl %" SVf " required--this is only "
SV *hintsv;
I32 second = 0;
- if (av_tindex(lav)>=1)
+ if (av_count(lav) > 1)
second = SvIV(*av_fetch(lav,1,0));
second /= second >= 600 ? 100 : 10;
* the second form */
static OP *
-S_require_file(pTHX_ SV *const sv)
+S_require_file(pTHX_ SV *sv)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
const char *name;
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;
+ SV *namesv = NULL; /* SV equivalent of tryname */
const U8 gimme = GIMME_V;
int filter_has_file = 0;
PerlIO *tryrsfp = NULL;
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;
assert(op_is_require || PL_op->op_type == OP_DOFILE);
if (!(name && len > 0 && *name))
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 && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES;
+ }
+#endif
+
if (!IS_SAFE_PATHNAME(name, len, op_name)) {
if (!op_is_require) {
CLEAR_ERRSV();
unixlen = len;
}
if (op_is_require) {
- SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
- unixname, unixlen, 0);
+ /* 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)
+ /* we already did a get magic if this was cached */
+ if (!svp_cached)
+ SvGETMAGIC(*svp);
+ if (SvOK(*svp))
RETPUSHYES;
else
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)) {
- /* require foo (or use foo) with a bareword.
- Perl_load_module fakes up the identical optree, but its
- arguments aren't restricted by the parser to real barewords.
- */
+ /* 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
directory, or (*nix) hidden filenames. Also sanity check
that the generated filename ends .pm */
if (!path_searchable || len < 3 || name[0] == '.'
- || !memEQ(name + package_len, ".pm", 3))
+ || !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" */
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 non-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;
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;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
#else
-# ifdef __SYMBIAN32__
- if (PL_origfilename[0] &&
- PL_origfilename[1] == ':' &&
- !(dir[0] && dir[1] == ':'))
- Perl_sv_setpvf(aTHX_ namesv,
- "%c:%s\\%s",
- PL_origfilename[0],
- dir, name);
- else
- Perl_sv_setpvf(aTHX_ namesv,
- "%s\\%s",
- dir, name);
-# 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(op_name);
tryname = SvPVX_const(namesv);
*/
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) {
+ /* 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_catpvs(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_catpvs(msg, " module)");
+ }
}
- else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
- sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
+ else if (memENDs(name, len, ".h")) {
+ sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
}
- else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
- sv_catpv(msg, " (did you run h2ph?)");
+ else if (memENDs(name, len, ".ph")) {
+ sv_catpvs(msg, " (did you run h2ph?)");
}
/* diag_listed_as: Can't locate %s */
}
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 */
+ assert(!CATCH_GET);
cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix);
cx_pusheval(cx, PL_op->op_next, newSVpv(name, 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;
PP(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);
+ 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);
+ }
}
dSP;
PERL_CONTEXT *cx;
SV *sv;
- const U8 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));
}
* to do the dirty work for us */
runcv = find_runcv(&seq);
+ assert(!CATCH_GET);
cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix);
cx_pusheval(cx, PL_op->op_next, NULL);
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(). */
/* did require return a false value? */
failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
&& !(gimme == G_SCALAR
- ? SvTRUE(*PL_stack_sp)
+ ? 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);
PP(pp_entertry)
{
+ RUN_PP_CATCHABLY(Perl_pp_entertry);
+
+ assert(!CATCH_GET);
create_eval_scope(cLOGOP->op_other->op_next, 0);
- return DOCATCH(PL_op->op_next);
+ return PL_op->op_next;
}
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);
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
/* Test sub truth for each element */
- SSize_t i;
+ Size_t i;
bool andedresults = TRUE;
AV *av = (AV*) SvRV(d);
- const I32 len = av_tindex(av);
+ const Size_t len = av_count(av);
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
- if (len == -1)
+ if (len == 0)
RETPUSHYES;
- for (i = 0; i <= len; ++i) {
+ 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");
}
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;
+ const Size_t other_len = av_count(other_av);
+ Size_t i;
HV *hv = MUTABLE_HV(SvRV(e));
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
}
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;
+ const Size_t other_len = av_count(other_av);
+ Size_t i;
DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
for (i = 0; i < other_len; ++i) {
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))
+ if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
RETPUSHNO;
else {
- SSize_t i;
- const SSize_t other_len = av_tindex(other_av);
+ Size_t i;
+ const Size_t other_len = av_count(other_av);
if (NULL == seen_this) {
seen_this = newHV();
seen_other = newHV();
(void) sv_2mortal(MUTABLE_SV(seen_other));
}
- for(i = 0; i <= other_len; ++i) {
+ 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);
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;
+ const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
+ Size_t i;
- for(i = 0; i <= this_len; ++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;
}
else if (!SvOK(d)) {
/* undef ~~ array */
- const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
- SSize_t i;
+ const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
+ Size_t i;
DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
- for (i = 0; i <= this_len; ++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 for undef element...\n"));
if (!svp || !SvOK(*svp))
else {
sm_any_array:
{
- SSize_t i;
- const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
+ Size_t i;
+ const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
- for (i = 0; i <= this_len; ++i) {
+ for (i = 0; i < this_len; ++i) {
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
if (!svp)
continue;
to the op that follows the leavewhen.
RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
*/
- if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs))
+ if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) {
+ if (gimme == G_SCALAR)
+ PUSHs(&PL_sv_undef);
RETURNOP(cLOGOP->op_other->op_next);
+ }
cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix);
cx_pushwhen(cx);
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);
}