#define tryAMAGICregexp(rx) \
STMT_START { \
+ SvGETMAGIC(rx); \
if (SvROK(rx) && SvAMAGIC(rx)) { \
SV *sv = AMG_CALLun(rx, regexp); \
if (sv) { \
sv_setpvs(tmpstr, "");
while (++MARK <= SP) {
SV *msv = *MARK;
- if (PL_amagic_generation) {
- SV *sv;
+ SV *sv;
- tryAMAGICregexp(msv);
+ tryAMAGICregexp(msv);
- if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
- (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
- {
- sv_setsv(tmpstr, sv);
- continue;
- }
+ if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
+ (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
+ {
+ sv_setsv(tmpstr, sv);
+ continue;
}
sv_catsv(tmpstr, msv);
}
PM_SETRE(pm, re);
}
else {
- STRLEN len;
- const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
+ STRLEN len = 0;
+ const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
+
re = PM_GETRE(pm);
assert (re != (REGEXP*) &PL_sv_undef);
const char *const p = SvPV(tmpstr, len);
tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
}
+ else if (SvAMAGIC(tmpstr)) {
+ /* make a copy to avoid extra stringifies */
+ tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
+ }
- if (eng)
+ if (eng)
PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
- else
+ else
PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
SvPV_set(dstr, NULL);
TAINT_IF(cx->sb_rxtainted & 1);
- mPUSHi(saviters - 1);
+ if (pm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(targ);
+ else
+ mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
TAINT_IF(cx->sb_rxtainted);
}
void
-Perl_die_where(pTHX_ SV *msv)
+Perl_die_unwind(pTHX_ SV *msv)
{
dVAR;
+ SV *exceptsv = sv_mortalcopy(msv);
+ U8 in_eval = PL_in_eval;
+ PERL_ARGS_ASSERT_DIE_UNWIND;
- if (PL_in_eval) {
+ if (in_eval) {
I32 cxix;
I32 gimme;
- if (msv) {
- if (PL_in_eval & EVAL_KEEPERR) {
- static const char prefix[] = "\t(in cleanup) ";
- SV * const err = ERRSV;
- const char *e = NULL;
- if (!SvPOK(err))
- sv_setpvs(err,"");
- else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
- STRLEN len;
- STRLEN msglen;
- const char* message = SvPV_const(msv, msglen);
- e = SvPV_const(err, len);
- e += len - msglen;
- if (*e != *message || strNE(e,message))
- e = NULL;
- }
- if (!e) {
- STRLEN start;
- SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
- sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catsv(err, msv);
- start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
- SvPVX_const(err)+start);
- }
- }
- else {
- STRLEN msglen;
- const char* message = SvPV_const(msv, msglen);
- sv_setpvn(ERRSV, message, msglen);
- SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
- }
- }
-
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
{
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
STRLEN msglen;
- const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
+ const char* message = SvPVx_const(exceptsv, msglen);
PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
PL_curcop = cx->blk_oldcop;
if (optype == OP_REQUIRE) {
- const char* const msg = SvPVx_nolen_const(ERRSV);
+ const char* const msg = SvPVx_nolen_const(exceptsv);
(void)hv_store(GvHVn(PL_incgv),
SvPVX_const(namesv), SvCUR(namesv),
&PL_sv_undef, 0);
* supposed to trap errors. So now that we've popped the
* EVAL that pp_require pushed, and processed the error
* message, rethrow the error */
- DIE(aTHX_ "%sCompilation failed in require",
- *msg ? msg : "Unknown error\n");
+ Perl_croak(aTHX_ "%sCompilation failed in require",
+ *msg ? msg : "Unknown error\n");
+ }
+ if (in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
+ SvPV_nolen_const(exceptsv));
+ }
+ else {
+ sv_setsv(ERRSV, exceptsv);
}
assert(CxTYPE(cx) == CXt_EVAL);
PL_restartjmpenv = cx->blk_eval.cur_top_env;
}
}
- write_to_stderr( msv ? msv : ERRSV );
+ write_to_stderr(exceptsv);
my_failure_exit();
/* NOTREACHED */
}
AV * const ary = cx->blk_sub.argarray;
const int off = AvARRAY(ary) - AvALLOC(ary);
- if (!PL_dbargs) {
- PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
- SVt_PVAV)));
- AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
- }
+ if (!PL_dbargs)
+ Perl_init_dbargs(aTHX);
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
av_extend(PL_dbargs, AvFILLp(ary) + off);
int runtime;
CV* runcv = NULL; /* initialise to avoid compiler warnings */
STRLEN len;
+ bool need_catch;
PERL_ARGS_ASSERT_SV_COMPILE_2OP;
PL_op->op_flags = 0; /* Avoid uninit warning. */
PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
PUSHEVAL(cx, 0);
+ need_catch = CATCH_GET;
+ CATCH_SET(TRUE);
if (runtime)
(void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
else
(void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
+ CATCH_SET(need_catch);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
else
CLEAR_ERRSV();
+ CALL_BLOCK_HOOKS(eval, saveop);
+
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
* so honour CATCH_GET and trap it here if necessary */
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
+ /* note that if yystatus == 3, then the EVAL CX block has already
+ * been popped, and various vars restored */
PL_op = saveop;
- if (PL_eval_root) {
- op_free(PL_eval_root);
- PL_eval_root = NULL;
- }
if (yystatus != 3) {
+ if (PL_eval_root) {
+ op_free(PL_eval_root);
+ PL_eval_root = NULL;
+ }
SP = PL_stack_base + POPMARK; /* pop original mark */
if (!startop) {
POPBLOCK(cx,PL_curpm);
}
}
- /* We do this only with use, not require. */
- if (PL_compcv &&
- /* If we request a version >= 5.9.5, load feature.pm with the
- * feature bundle that corresponds to the required version. */
- vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
- SV *const importsv = vnormal(sv);
- *SvPVX_mutable(importsv) = ':';
- ENTER_with_name("load_feature");
- Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
- LEAVE_with_name("load_feature");
- }
- /* If a version >= 5.11.0 is requested, strictures are on by default! */
- if (PL_compcv &&
- vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
- PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ /* We do this only with "use", not "require" or "no". */
+ if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
+ /* If we request a version >= 5.9.5, load feature.pm with the
+ * feature bundle that corresponds to the required version. */
+ if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
+ SV *const importsv = vnormal(sv);
+ *SvPVX_mutable(importsv) = ':';
+ ENTER_with_name("load_feature");
+ Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
+ LEAVE_with_name("load_feature");
+ }
+ /* If a version >= 5.11.0 is requested, strictures are on by default! */
+ if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
+ PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ }
}
RETPUSHYES;
count = call_sv(loader, G_ARRAY);
SPAGAIN;
- /* Adjust file name if the hook has set an %INC entry */
- svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
- if (svp)
- tryname = SvPV_nolen_const(*svp);
-
if (count > 0) {
int i = 0;
SV *arg;
FREETMPS;
LEAVE_with_name("call_INC");
+ /* Adjust file name if the hook has set an %INC entry.
+ This needs to happen after the FREETMPS above. */
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (svp)
+ tryname = SvPV_nolen_const(*svp);
+
if (tryrsfp) {
hook_sv = dirsv;
break;
}
}
}
- SAVECOPFILE_FREE(&PL_compiling);
- CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
+ if (tryrsfp) {
+ SAVECOPFILE_FREE(&PL_compiling);
+ CopFILE_set(&PL_compiling, tryname);
+ }
SvREFCNT_dec(namesv);
if (!tryrsfp) {
if (PL_op->op_type == OP_REQUIRE) {
- const char *msgstr = name;
if(errno == EMFILE) {
- SV * const msg
- = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
- Strerror(errno)));
- msgstr = SvPV_nolen_const(msg);
+ /* diag_listed_as: Can't locate %s */
+ DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
} else {
if (namesv) { /* did we lookup @INC? */
AV * const ar = GvAVn(PL_incgv);
I32 i;
- SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
- "%s in @INC%s%s (@INC contains:",
- msgstr,
- (instr(msgstr, ".h ")
- ? " (change .h to .ph maybe?)" : ""),
- (instr(msgstr, ".ph ")
- ? " (did you run h2ph?)" : "")
- ));
-
+ SV *const inc = newSVpvs_flags("", SVs_TEMP);
for (i = 0; i <= AvFILL(ar); i++) {
- sv_catpvs(msg, " ");
- sv_catsv(msg, *av_fetch(ar, i, TRUE));
+ sv_catpvs(inc, " ");
+ sv_catsv(inc, *av_fetch(ar, i, TRUE));
}
- sv_catpvs(msg, ")");
- msgstr = SvPV_nolen_const(msg);
- }
+
+ /* diag_listed_as: Can't locate %s */
+ DIE(aTHX_
+ "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
+ name,
+ (memEQ(name + len - 2, ".h", 3)
+ ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
+ (memEQ(name + len - 3, ".ph", 4)
+ ? " (did you run h2ph?)" : ""),
+ inc
+ );
+ }
}
- DIE(aTHX_ "Can't locate %s", msgstr);
+ DIE(aTHX_ "Can't locate %s", name);
}
RETPUSHUNDEF;
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
}
sv = POPs;
+ if (!SvPOK(sv)) {
+ /* make sure we've got a plain PV (no overload etc) before testing
+ * for taint. Making a copy here is probably overkill, but better
+ * safe than sorry */
+ STRLEN len;
+ const char * const p = SvPV_const(sv, len);
+
+ sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
+ }
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
G_DISCARD);
retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
SVfARG(namesv));
- /* die_where() did LEAVE, or we won't be here */
+ /* die_unwind() did LEAVE, or we won't be here */
}
else {
LEAVE_with_name("eval");
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_GIVEN);
- SP = newsp;
- PUTBACK;
-
- PL_curpm = newpm; /* pop $1 et al */
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ SP = newsp;
+ else if (gimme == G_SCALAR) {
+ register SV **mark;
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
+ else {
+ MEXTEND(mark,0);
+ *MARK = &PL_sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ /* in case LEAVE wipes old return values */
+ register SV **mark;
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
+ *mark = sv_mortalcopy(*mark);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ }
+ PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE_with_name("given");
-
- return NORMAL;
+ RETURN;
}
/* Helper routines used by pp_smartmatch */
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 (SvGMAGICAL(d))
+ d = sv_mortalcopy(d);
+ }
+ else
+ d = &PL_sv_undef;
+
+ assert(e);
+ if (SvGMAGICAL(e))
+ e = sv_mortalcopy(e);
+
/* First of all, handle overload magic of the rightmost argument */
if (SvAMAGIC(e)) {
SV * tmpsv;
SP -= 2; /* Pop the values */
- /* 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 (SvGMAGICAL(d))
- d = sv_mortalcopy(d);
- }
- else
- d = &PL_sv_undef;
-
- assert(e);
- if (SvGMAGICAL(e))
- e = sv_mortalcopy(e);
/* ~~ undef */
if (!SvOK(e)) {
fails, we don't want to push a context and then
pop it again right away, so we skip straight
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))
- return cLOGOP->op_other->op_next;
+ RETURNOP(cLOGOP->op_other->op_next);
ENTER_with_name("eval");
SAVETMPS;
I32 cxix;
register PERL_CONTEXT *cx;
I32 inner;
-
+ dSP;
+
cxix = dopoptogiven(cxstack_ix);
if (cxix < 0) {
if (PL_op->op_flags & OPf_SPECIAL)
if (CxFOREACH(cx))
return CX_LOOP_NEXTOP_GET(cx);
else
- return cx->blk_givwhen.leave_op;
+ /* RETURNOP calls PUTBACK which restores the old old sp */
+ RETURNOP(cx->blk_givwhen.leave_op);
}
STATIC OP *
https://perl5.git.perl.org / perl5.git / blobdiff