case OP_MATCH:
case OP_QR:
clear_pmop:
- op_free(cPMOPo->op_code_list);
+ if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
+ op_free(cPMOPo->op_code_list);
cPMOPo->op_code_list = NULL;
forget_pmop(cPMOPo, 1);
cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
else
scalar(PL_eval_root);
- /* don't use LINKLIST, since PL_eval_root might indirect through
- * a rather expensive function call and LINKLIST evaluates its
- * argument more than once */
PL_eval_start = op_linklist(PL_eval_root);
PL_eval_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_eval_root, 1);
bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
bool is_compiletime;
bool has_code;
- bool ext_eng;
- regexp_engine *eng;
PERL_ARGS_ASSERT_PMRUNTIME;
return pmtrans(o, expr, repl);
}
- /* find whether we have any runtime or code elements */
+ /* find whether we have any runtime or code elements;
+ * at the same time, temporarily set the op_next of each DO block;
+ * then when we LINKLIST, this will cause the DO blocks to be excluded
+ * from the op_next chain (and from having LINKLIST recursively
+ * applied to them). We fix up the DOs specially later */
is_compiletime = 1;
has_code = 0;
if (expr->op_type == OP_LIST) {
OP *o;
for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
- if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
+ if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
has_code = 1;
+ assert(!o->op_next && o->op_sibling);
+ o->op_next = o->op_sibling;
+ }
else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
is_compiletime = 0;
}
else if (expr->op_type != OP_CONST)
is_compiletime = 0;
- /* are we using an external (non-perl) re engine? */
-
- eng = current_re_engine();
- ext_eng = (eng && eng != &PL_core_reg_engine);
+ LINKLIST(expr);
- /* for perl engine:
- * concatenate adjacent CONSTs for non-code case
- * pre-process DO blocks;
- * for non-perl engines:
- * concatenate adjacent CONSTs;
- * strip out any DO blocks
- */
+ /* fix up DO blocks; treat each one as a separate little sub */
if (expr->op_type == OP_LIST) {
- OP *kid, *okid = NULL;
- kid = cLISTOPx(expr)->op_first;
- while (kid) {
- if (kid->op_type == OP_NULL && (kid->op_flags & OPf_SPECIAL)) {
- /* do {...} */
- if (ext_eng || !is_compiletime/*XXX tmp*/ ) {
- /* discard DO block */
- assert(okid);
- okid->op_sibling = kid->op_sibling;
- kid->op_sibling = NULL;
- op_free(kid);
- kid = okid;
- }
- else {
- /* treat each DO block as a separate little sub */
- scalar(kid);
- LINKLIST(kid);
- if (kLISTOP->op_first->op_type == OP_LEAVE) {
- LISTOP *leave = cLISTOPx(kLISTOP->op_first);
- /* skip ENTER */
- assert(leave->op_first->op_type == OP_ENTER);
- assert(leave->op_first->op_sibling);
- kid->op_next = leave->op_first->op_sibling;
- /* skip LEAVE */
- assert(leave->op_flags & OPf_KIDS);
- assert(leave->op_last->op_next = (OP*)leave);
- leave->op_next = NULL; /* stop on last op */
- op_null((OP*)leave);
- }
- else {
- /* skip SCOPE */
- OP *scope = kLISTOP->op_first;
- assert(scope->op_type == OP_SCOPE);
- assert(scope->op_flags & OPf_KIDS);
- scope->op_next = NULL; /* stop on last op */
- op_null(scope);
- }
- CALL_PEEP(kid);
- finalize_optree(kid);
- }
+ OP *o;
+ for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+ if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
+ continue;
+ o->op_next = NULL; /* undo temporary hack from above */
+ scalar(o);
+ LINKLIST(o);
+ if (cLISTOPo->op_first->op_type == OP_LEAVE) {
+ LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
+ /* skip ENTER */
+ assert(leave->op_first->op_type == OP_ENTER);
+ assert(leave->op_first->op_sibling);
+ o->op_next = leave->op_first->op_sibling;
+ /* skip LEAVE */
+ assert(leave->op_flags & OPf_KIDS);
+ assert(leave->op_last->op_next = (OP*)leave);
+ leave->op_next = NULL; /* stop on last op */
+ op_null((OP*)leave);
}
- else if ( (ext_eng || !has_code || !is_compiletime/*XXX tmp*/)
- && kid->op_type == OP_CONST
- && kid->op_sibling
- && kid->op_sibling->op_type == OP_CONST)
- {
- /* concat adjacent CONSTs */
- OP *o = kid->op_sibling;
- SV* sv = cSVOPx_sv(kid);
- SvREADONLY_off(sv);
- sv_catsv(sv, cSVOPo_sv);
- SvREADONLY_on(sv);
- kid->op_sibling = o->op_sibling;
- o->op_sibling = NULL;
- op_free(o);
- kid = okid;
+ else {
+ /* skip SCOPE */
+ OP *scope = cLISTOPo->op_first;
+ assert(scope->op_type == OP_SCOPE);
+ assert(scope->op_flags & OPf_KIDS);
+ scope->op_next = NULL; /* stop on last op */
+ op_null(scope);
}
- okid = kid;
- kid = kid->op_sibling;
+ /* have to peep the DOs individually as we've removed it from
+ * the op_next chain */
+ CALL_PEEP(o);
+ if (is_compiletime)
+ /* runtime finalizes as part of finalizing whole tree */
+ finalize_optree(o);
}
- cLISTOPx(expr)->op_last = okid;
}
PL_hints |= HINT_BLOCK_SCOPE;
assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
if (is_compiletime) {
- U32 pm_flags = pm->op_pmflags & (RXf_PMf_COMPILETIME|PMf_HAS_CV);
+ U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
+ regexp_engine const *eng = current_re_engine();
if (o->op_flags & OPf_SPECIAL)
- pm_flags |= RXf_SPLIT;
+ rx_flags |= RXf_SPLIT;
- if (!has_code || ext_eng) {
+ if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
- SV *pat;
- assert( expr->op_type == OP_CONST
- || ( expr->op_type == OP_LIST
- && cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK
- && cLISTOPx(expr)->op_first->op_sibling
- && cLISTOPx(expr)->op_first->op_sibling->op_type == OP_CONST
- && !cLISTOPx(expr)->op_first->op_sibling->op_sibling
- )
- );
- pat = ((SVOP*)(expr->op_type == OP_LIST
- ? cLISTOPx(expr)->op_first->op_sibling : expr))->op_sv;
-
if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
/* whoops! we guessed that a qr// had a code block, but we
pm->op_pmflags &= ~PMf_HAS_CV;
}
- if (DO_UTF8(pat)) {
- assert (SvUTF8(pat));
- } else if (SvUTF8(pat)) {
- /* Not doing UTF-8, despite what the SV says. Is this only if we're
- trapped in use 'bytes'? */
- /* Make a copy of the octet sequence, but without the flag on, as
- the compiler now honours the SvUTF8 flag on pat. */
- STRLEN len;
- const char *const p = SvPV(pat, len);
- pat = newSVpvn_flags(p, len, SVs_TEMP);
- }
-
- PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
+ PM_SETRE(pm,
+ eng->op_comp
+ ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags, pm->op_pmflags)
+ : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags, pm->op_pmflags)
+ );
#ifdef PERL_MAD
op_getmad(expr,(OP*)pm,'e');
#else
}
else {
/* compile-time pattern that includes literal code blocks */
- REGEXP* re = re_op_compile(NULL, expr, pm_flags);
+ REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
+ rx_flags,
+ (pm->op_pmflags |
+ ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
+ );
PM_SETRE(pm, re);
if (pm->op_pmflags & PMf_HAS_CV) {
CV *cv;
else {
/* runtime pattern: build chain of regcomp etc ops */
bool reglist;
+ PADOFFSET cv_targ = 0;
reglist = isreg && expr->op_type == OP_LIST;
if (reglist)
op_null(expr);
- if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
- expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
- ? OP_REGCRESET
- : OP_REGCMAYBE),0,expr);
+ if (has_code) {
+ pm->op_code_list = expr;
+ /* don't free op_code_list; its ops are embedded elsewhere too */
+ pm->op_pmflags |= PMf_CODELIST_PRIVATE;
+ }
+
+ /* the OP_REGCMAYBE is a placeholder in the non-threaded case
+ * to allow its op_next to be pointed past the regcomp and
+ * preceding stacking ops;
+ * OP_REGCRESET is there to reset taint before executing the
+ * stacking ops */
+ if (pm->op_pmflags & PMf_KEEP || PL_tainting)
+ expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
if (pm->op_pmflags & PMf_HAS_CV) {
/* we have a runtime qr with literal code. This means
*/
SvREFCNT_inc_simple_void(PL_compcv);
- expr = list(force_list(newUNOP(OP_ENTERSUB, 0,
- scalar(newANONATTRSUB(floor, NULL, NULL, expr)))));
+ /* these lines are just an unrolled newANONATTRSUB */
+ expr = newSVOP(OP_ANONCODE, 0,
+ MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
+ cv_targ = expr->op_targ;
+ expr = newUNOP(OP_REFGEN, 0, expr);
+
+ expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
}
NewOp(1101, rcop, 1, LOGOP);
rcop->op_flags |= OPf_KIDS
| ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
- rcop->op_private = 1;
+ rcop->op_private = 0;
rcop->op_other = o;
- if (reglist)
- rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
+ rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
OP *imop;
OP *veop;
#ifdef PERL_MAD
- OP *pegop = newOP(OP_NULL,0);
+ OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
#endif
SV *use_version = NULL;
PL_cop_seqmax++;
#ifdef PERL_MAD
- if (!PL_madskills) {
- /* FIXME - don't allocate pegop if !PL_madskills */
- op_free(pegop);
- return NULL;
- }
return pegop;
#endif
}
U32 ps_utf8 = 0;
register CV *cv = NULL;
SV *const_sv;
+ const bool ec = PL_parser && PL_parser->error_count;
/* If the subroutine has no body, no attributes, and no builtin attributes
then it's just a sub declaration, and we may be able to get away with
storing with a placeholder scalar in the symbol table, rather than a
full GV and CV. If anything is present then it will take a full CV to
store it. */
const I32 gv_fetch_flags
- = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ = ec ? GV_NOADD_NOINIT :
+ (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
STRLEN namlen = 0;
SAVEFREEOP(attrs);
}
+ if (ec) {
+ op_free(block);
+ if (name && block) {
+ const char *s = strrchr(name, ':');
+ s = s ? s+1 : name;
+ if (strEQ(s, "BEGIN")) {
+ const char not_safe[] =
+ "BEGIN not safe after errors--compilation aborted";
+ if (PL_in_eval & EVAL_KEEPERR)
+ Perl_croak(aTHX_ not_safe);
+ else {
+ /* force display of errors found but not reported */
+ sv_catpv(ERRSV, not_safe);
+ Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
+ }
+ }
+ }
+ cv = PL_compcv;
+ goto done;
+ }
+
if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
maximum a prototype before. */
if (SvTYPE(gv) > SVt_NULL) {
}
}
if (const_sv) {
- HV *stash;
SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
const_sv
);
}
- stash =
- (CvGV(cv) && GvSTASH(CvGV(cv)))
- ? GvSTASH(CvGV(cv))
- : CvSTASH(cv)
- ? CvSTASH(cv)
- : PL_curstash;
- if (HvENAME_HEK(stash))
- mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
if (PL_madskills)
goto install_block;
op_free(block);
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
}
- if (PL_parser && PL_parser->error_count) {
- op_free(block);
- block = NULL;
- if (name) {
- const char *s = strrchr(name, ':');
- s = s ? s+1 : name;
- if (strEQ(s, "BEGIN")) {
- const char not_safe[] =
- "BEGIN not safe after errors--compilation aborted";
- if (PL_in_eval & EVAL_KEEPERR)
- Perl_croak(aTHX_ not_safe);
- else {
- /* force display of errors found but not reported */
- sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
- }
- }
- }
- }
install_block:
if (!block)
goto attrs;
return cv;
}
+CV *
+Perl_newSTUB(pTHX_ GV *gv, bool fake)
+{
+ register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ PERL_ARGS_ASSERT_NEWSTUB;
+ assert(!GvCVu(gv));
+ GvCV_set(gv, cv);
+ GvCVGEN(gv) = 0;
+ if (!fake && HvENAME_HEK(GvSTASH(gv)))
+ mro_method_changed_in(GvSTASH(gv));
+ CvGV_set(cv, gv);
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+ GvMULTI_on(gv);
+ return cv;
+}
+
/*
=for apidoc U||newXS
https://perl5.git.perl.org / perl5.git / blobdiff