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) {
+ if (PL_curpm_under == PL_reg_curpm) {
+ Perl_croak(aTHX_ "Infinite recursion via empty pattern");
+ } else {
+ pm = PL_curpm_under;
+ }
+ }
+ } else {
+ pm = PL_curpm;
+ }
+ }
+
#if !defined(USE_ITHREADS)
/* can't change the optree at runtime either */
/* PMf_KEEP is handled differently under threads to avoid these problems */
- if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
- pm = PL_curpm;
if (pm->op_pmflags & PMf_KEEP) {
- pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
cLOGOP->op_first->op_next = PL_op->op_next;
}
#endif
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);
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++;
}
}
+/* also used for: pp_mapstart() */
PP(pp_grepstart)
{
dSP;
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))
switch (CxTYPE(cx)) {
case CXt_SUBST:
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:
cx_popsub(cx);
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;
}
static void
S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
{
- SV *namesv;
+ SV *namesv = NULL; /* init to avoid dumb compiler warning */
bool do_croak;
CX_LEAVE_SCOPE(cx);
if (action == 1) {
(void)hv_delete(inc_hv, key, klen, G_DISCARD);
- fmt = "%"SVf" did not return a true value";
+ 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";
+ fmt = "%" SVf "Compilation failed in require";
if (!errsv)
errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
}
(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));
}
{
PERL_CONTEXT *cx;
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);
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)
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");
}
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");
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
}
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
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",
+ DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
SVfARG(sv_2mortal(vnormal(sv))),
SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
);
|| 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",
+ DIE(aTHX_ "Perl %" SVf " required--this is only "
+ "%" SVf ", stopped",
SVfARG(sv_2mortal(vnormal(req))),
SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
);
(int)first, (int)second);
upg_version(hintsv, TRUE);
- DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
- "--this is only %"SVf", stopped",
+ 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)))
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";
+
+ assert(op_is_require || PL_op->op_type == OP_DOFILE);
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);
- 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),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) {
+ if (op_is_require) {
SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
unixname, unixlen, 0);
if ( svp ) {
that the generated filename ends .pm */
if (!path_searchable || len < 3 || name[0] == '.'
|| !memEQ(name + package_len, ".pm", 3))
- DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
+ 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\"");
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;
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 =
}
# endif
#endif
- TAINT_PROPER("require");
+ TAINT_PROPER(op_name);
tryname = SvPVX_const(namesv);
tryrsfp = doopen_pm(namesv);
if (tryrsfp) {
saved_errno = errno; /* sv_2mortal can realloc things */
sv_2mortal(namesv);
if (!tryrsfp) {
- if (PL_op->op_type == OP_REQUIRE) {
+ 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",
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);
https://perl5.git.perl.org / perl5.git / blobdiff