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
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
- sv_setpvs(TARG, "");
+ SvPVCLEAR(TARG);
SETs(targ);
RETURN;
}
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;
}
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));
}
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