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);
assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
if (is_compiletime) {
- U32 pm_flags = pm->op_pmflags & (RXf_PMf_COMPILETIME|PMf_HAS_CV);
- regexp_engine *eng = current_re_engine();
+ 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 || (eng && eng != &PL_core_reg_engine)) {
+ if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
- SV *pat;
-
- if (expr->op_type == OP_CONST)
- pat = cSVOPx_sv(expr);
- else {
- /* concat any CONSTs */
- OP *kid = cLISTOPx(expr)->op_first;
- pat = NULL;
- for (; kid; kid = kid->op_sibling) {
- if (kid->op_type != OP_CONST)
- continue;
- if (pat)
- sv_catsv(pat, cSVOPx_sv(kid));
- else {
- pat = cSVOPx_sv(kid);
- SvREADONLY_off(pat);
- }
- }
- assert(pat);
- }
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, 0, expr, NULL, NULL, NULL, 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;
pm->op_pmflags |= PMf_CODELIST_PRIVATE;
}
- if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
- expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
- ? OP_REGCRESET
- : OP_REGCMAYBE),0,expr);
+ /* 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
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