PP(pp_regcomp)
{
dSP;
- PMOP *pm = (PMOP*)cLOGOP->op_other;
+ PMOP *pm = cPMOPx(cLOGOP->op_other);
SV **args;
int nargs;
REGEXP *re = NULL;
{
dSP;
PERL_CONTEXT *cx = CX_CUR();
- PMOP * const pm = (PMOP*) cLOGOP->op_other;
+ PMOP * const pm = cPMOPx(cLOGOP->op_other);
SV * const dstr = cx->sb_dstr;
char *s = cx->sb_s;
char *m = cx->sb_m;
sv_catsv(PL_errors, err);
else
Perl_warn(aTHX_ "%" SVf, SVfARG(err));
- if (PL_parser)
+
+ if (PL_parser) {
+ STRLEN len;
+ char *err_pv = SvPV(err,len);
++PL_parser->error_count;
+ if (memBEGINs(err_pv,len,"syntax error"))
+ {
+ PL_parser->error_count |= PERL_PARSE_IS_SYNTAX_ERROR_FLAG;
+ }
+ }
}
mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
- STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
+ char *old_warnings = cx->blk_oldcop->cop_warnings;
if (old_warnings == pWARN_NONE)
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
mask = newSVpvn(WARN_ALLstring, WARNsize) ;
}
else
- mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
+ mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings));
mPUSHs(mask);
}
}
-/* Run yyparse() in a setjmp wrapper. Returns:
+/* S_try_yyparse():
+ *
+ * Run yyparse() in a setjmp wrapper. Returns:
* 0: yyparse() successful
* 1: yyparse() failed
* 3: yyparse() died
+ *
+ * This is used to trap Perl_croak() calls that are executed
+ * during the compilation process and before the code has been
+ * completely compiled. It is expected to be called from
+ * doeval_compile() only. The parameter 'caller_op' is
+ * only used in DEBUGGING to validate the logic is working
+ * correctly.
+ *
+ * See also try_run_unitcheck().
+ *
*/
STATIC int
-S_try_yyparse(pTHX_ int gramtype)
+S_try_yyparse(pTHX_ int gramtype, OP *caller_op)
{
- int ret;
+ /* if we die during compilation PL_restartop and PL_restartjmpenv
+ * will be set by Perl_die_unwind(). We need to restore their values
+ * if that happens as they are intended for the case where the code
+ * compiles and dies during execution, not where it dies during
+ * compilation. PL_restartop and caller_op->op_next should be the
+ * same anyway, and when compilation fails then caller_op->op_next is
+ * used as the next op after the compile.
+ */
+ JMPENV *restartjmpenv = PL_restartjmpenv;
+ OP *restartop = PL_restartop;
dJMPENV;
+ int ret;
+ PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
assert(CxTYPE(CX_CUR()) == CXt_EVAL);
JMPENV_PUSH(ret);
ret = yyparse(gramtype) ? 1 : 0;
break;
case 3:
+ /* yyparse() died and we trapped the error. We need to restore
+ * the old PL_restartjmpenv and PL_restartop values. */
+ assert(PL_restartop == caller_op->op_next); /* we expect these to match */
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
break;
default:
JMPENV_POP;
return ret;
}
+/* S_try_run_unitcheck()
+ *
+ * Run PL_unitcheckav in a setjmp wrapper via call_list.
+ * Returns:
+ * 0: unitcheck blocks ran without error
+ * 3: a unitcheck block died
+ *
+ * This is used to trap Perl_croak() calls that are executed
+ * during UNITCHECK blocks executed after the compilation
+ * process has completed but before the code itself has been
+ * executed via the normal run loops. It is expected to be called
+ * from doeval_compile() only. The parameter 'caller_op' is
+ * only used in DEBUGGING to validate the logic is working
+ * correctly.
+ *
+ * See also try_yyparse().
+ */
+STATIC int
+S_try_run_unitcheck(pTHX_ OP* caller_op)
+{
+ /* if we die during compilation PL_restartop and PL_restartjmpenv
+ * will be set by Perl_die_unwind(). We need to restore their values
+ * if that happens as they are intended for the case where the code
+ * compiles and dies during execution, not where it dies during
+ * compilation. UNITCHECK runs after compilation completes, and
+ * if it dies we will execute the PL_restartop anyway via the
+ * failed compilation code path. PL_restartop and caller_op->op_next
+ * should be the same anyway, and when compilation fails then
+ * caller_op->op_next is used as the next op after the compile.
+ */
+ JMPENV *restartjmpenv = PL_restartjmpenv;
+ OP *restartop = PL_restartop;
+ dJMPENV;
+ int ret;
+ PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
+
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ break;
+ case 3:
+ /* call_list died */
+ /* call_list() died and we trapped the error. We should restore
+ * the old PL_restartjmpenv and PL_restartop values, as they are
+ * used only in the case where the code was actually run.
+ * The assert validates that we will still execute the PL_restartop.
+ */
+ assert(PL_restartop == caller_op->op_next); /* we expect these to match */
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
+ break;
+ default:
+ JMPENV_POP;
+ JMPENV_JUMP(ret);
+ NOT_REACHED; /* NOTREACHED */
+ }
+ JMPENV_POP;
+ return ret;
+}
/* Compile a require/do or an eval ''.
*
CALL_BLOCK_HOOKS(bhk_eval, saveop);
- /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
- * so honour CATCH_GET and trap it here if necessary */
+ /* we should never be CATCH_GET true here, as our immediate callers should
+ * always handle that case. */
+ assert(!CATCH_GET);
+ /* compile the code */
- /* compile the code */
- yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
+ yystatus = (!in_require)
+ ? S_try_yyparse(aTHX_ GRAMPROG, saveop)
+ : yyparse(GRAMPROG);
if (yystatus || PL_parser->error_count || !PL_eval_root) {
PERL_CONTEXT *cx;
SV *errsv;
PL_op = saveop;
- /* note that if yystatus == 3, then the require/eval died during
- * compilation, so the EVAL CX block has already been popped, and
- * various vars restored */
if (yystatus != 3) {
+ /* note that if yystatus == 3, then the require/eval died during
+ * compilation, so the EVAL CX block has already been popped, and
+ * various vars restored. This block applies similar steps after
+ * the other "failed to compile" cases in yyparse, eg, where
+ * yystatus=1, "failed, but did not die". */
if (PL_eval_root) {
op_free(PL_eval_root);
PL_eval_root = NULL;
}
}
- if (PL_unitcheckav) {
+ if (PL_unitcheckav && av_count(PL_unitcheckav)>0) {
OP *es = PL_eval_start;
- call_list(PL_scopestack_ix, PL_unitcheckav);
+ /* TODO: are we sure we shouldn't do S_try_run_unitcheck()
+ * when `in_require` is true? */
+ if (in_require) {
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ }
+ else if (S_try_run_unitcheck(aTHX_ saveop)) {
+ /* there was an error! */
+
+ /* Restore PL_OP */
+ PL_op = saveop;
+
+ SV *errsv = ERRSV;
+ if (!*(SvPV_nolen_const(errsv))) {
+ /* This happens when using:
+ * eval qq# UNITCHECK { die "\x00"; } #;
+ */
+ sv_setpvs(errsv, "Unit check error");
+ }
+
+ if (gimme != G_LIST) PUSHs(&PL_sv_undef);
+ PUTBACK;
+ return FALSE;
+ }
PL_eval_start = es;
}
if (CATCH_GET)
return docatch(Perl_pp_entereval);
+ assert(!CATCH_GET);
+
gimme = GIMME_V;
was = PL_breakable_sub_gen;
saved_delete = FALSE;
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:%" LINE_Tf "]",
(unsigned long)++PL_evalseq,
- CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+ CopFILE(PL_curcop), CopLINE(PL_curcop));
tmpbuf = SvPVX(temp_sv);
len = SvCUR(temp_sv);
}
PERL_CONTEXT *cx;
OP *retop;
int failed;
+ bool override_return = FALSE; /* is feature 'module_true' in effect? */
CV *evalcv;
bool keep;
oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
- /* did require return a false value? */
- failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
+ bool is_require= CxOLD_OP_TYPE(cx) == OP_REQUIRE;
+ if (is_require) {
+ /* We are in an require. Check if use feature 'module_true' is enabled,
+ * and if so later on correct any returns from the require. */
+
+ /* we might be called for an OP_LEAVEEVAL or OP_RETURN opcode
+ * and the parse tree will look different for either case.
+ * so find the right op to check later */
+ if (OP_TYPE_IS_OR_WAS(PL_op, OP_RETURN)) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ override_return = true;
+ }
+ else if ((PL_op->op_flags & OPf_KIDS) && OP_TYPE_IS_OR_WAS(PL_op, OP_LEAVEEVAL)){
+ COP *old_pl_curcop = PL_curcop;
+ OP *check = cUNOPx(PL_op)->op_first;
+
+ /* ok, we found something to check, we need to scan through
+ * it and find the last OP_NEXTSTATE it contains and then read the
+ * feature state out of the COP data it contains.
+ */
+ if (check) {
+ if (!OP_TYPE_IS(check,OP_STUB)) {
+ const OP *kid = cLISTOPx(check)->op_first;
+ const OP *last_state = NULL;
+
+ for (; kid; kid = OpSIBLING(kid)) {
+ if (
+ OP_TYPE_IS_OR_WAS(kid, OP_NEXTSTATE)
+ || OP_TYPE_IS_OR_WAS(kid, OP_DBSTATE)
+ ){
+ last_state = kid;
+ }
+ }
+ if (last_state) {
+ PL_curcop = cCOPx(last_state);
+ if (FEATURE_MODULE_TRUE_IS_ENABLED) {
+ override_return = TRUE;
+ }
+ } else {
+ NOT_REACHED; /* NOTREACHED */
+ }
+ }
+ } else {
+ NOT_REACHED; /* NOTREACHED */
+ }
+ PL_curcop = old_pl_curcop;
+ }
+ }
+
+ /* we might override this later if 'module_true' is enabled */
+ failed = is_require
&& !(gimme == G_SCALAR
? SvTRUE_NN(*PL_stack_sp)
: PL_stack_sp > oldsp);
#endif
CvDEPTH(evalcv) = 0;
+ if (override_return) {
+ /* make sure that we use a standard return when feature 'module_load'
+ * is enabled. Returns from require are problematic (consider what happens
+ * when it is called twice) */
+ if (gimme == G_SCALAR) {
+ /* this following is an optimization of POPs()/PUSHs().
+ * and does the same thing with less bookkeeping */
+ *PL_stack_sp = &PL_sv_yes;
+ }
+ assert(gimme == G_VOID || gimme == G_SCALAR);
+ failed = 0;
+ }
+
/* pop the CXt_EVAL, and if a require failed, croak */
S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
STATIC PMOP *
S_make_matcher(pTHX_ REGEXP *re)
{
- PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
+ PMOP *matcher = cPMOPx(newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED));
PERL_ARGS_ASSERT_MAKE_MATCHER;
https://perl5.git.perl.org / perl5.git / blobdiff