X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/789fcc52f1a244cfb3e6199774a68c4dc8178682..8be227ab5e:/op.c diff --git a/op.c b/op.c index 718f0e6..41219df 100644 --- a/op.c +++ b/op.c @@ -102,6 +102,8 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" +#include "feature.h" +#include "regcomp.h" #define CALL_PEEP(o) PL_peepp(aTHX_ o) #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) @@ -296,6 +298,203 @@ Perl_Slab_Free(pTHX_ void *op) } } } +#else /* !defined(PL_OP_SLAB_ALLOC) */ + +/* See the explanatory comments above struct opslab in op.h. */ + +# ifndef PERL_SLAB_SIZE +# define PERL_SLAB_SIZE 64 +# endif + +/* rounds up to nearest pointer */ +# define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *)) +# define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o))) + +static OPSLAB * +S_new_slab(pTHX_ size_t sz) +{ + OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *)); + slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1); + return slab; +} + +void * +Perl_Slab_Alloc(pTHX_ size_t sz) +{ + dVAR; + OPSLAB *slab; + OPSLAB *slab2; + OPSLOT *slot; + OP *o; + size_t space; + + if (!PL_compcv || CvROOT(PL_compcv) + || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) + return PerlMemShared_calloc(1, sz); + + if (!CvSTART(PL_compcv)) { /* sneak it in here */ + CvSTART(PL_compcv) = + (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE)); + CvSLABBED_on(PL_compcv); + slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ + } + else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; + + sz = SIZE_TO_PSIZE(sz) + OPSLOT_HEADER_P; + + if (slab->opslab_freed) { + OP **too = &slab->opslab_freed; + o = *too; + while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) { + o = *(too = &o->op_next); + } + if (o) { + *too = o->op_next; + Zero(o, DIFF(o, OpSLOT(o)->opslot_next), I32 *); + o->op_slabbed = 1; + return (void *)o; + } + } + +# define INIT_OPSLOT \ + slot->opslot_slab = slab; \ + slot->opslot_next = slab2->opslab_first; \ + slab2->opslab_first = slot; \ + o = &slot->opslot_op; \ + o->op_slabbed = 1 + + /* The partially-filled slab is next in the chain. */ + slab2 = slab->opslab_next ? slab->opslab_next : slab; + if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) { + /* Remaining space is too small. */ + + OPSLAB *newslab; + + /* If we can fit a BASEOP, add it to the free chain, so as not + to waste it. */ + if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { + slot = &slab2->opslab_slots; + INIT_OPSLOT; + o->op_type = OP_FREED; + o->op_next = slab->opslab_freed; + slab->opslab_freed = o; + } + + /* Create a new slab. Make this one twice as big. */ + slot = slab2->opslab_first; + while (slot->opslot_next) slot = slot->opslot_next; + newslab = S_new_slab(aTHX_ DIFF(slab2, slot)*2); + newslab->opslab_next = slab->opslab_next; + slab->opslab_next = slab2 = newslab; + } + assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz); + + /* Create a new op slot */ + slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz); + assert(slot >= &slab2->opslab_slots); + INIT_OPSLOT; + return (void *)o; +} + +# undef INIT_OPSLOT + +/* This cannot possibly be right, but it was copied from the old slab + allocator, to which it was originally added, without explanation, in + commit 083fcd5. */ +# ifdef NETWARE +# define PerlMemShared PerlMem +# endif + +void +Perl_Slab_Free(pTHX_ void *op) +{ + OP * const o = (OP *)op; + OPSLAB *slab; + + PERL_ARGS_ASSERT_SLAB_FREE; + + if (!o->op_slabbed) { + PerlMemShared_free(op); + return; + } + + slab = OpSLAB(o); + /* If this op is already freed, our refcount will get screwy. */ + assert(o->op_type != OP_FREED); + o->op_type = OP_FREED; + o->op_next = slab->opslab_freed; + slab->opslab_freed = o; + OpslabREFCNT_dec_padok(slab); +} + +void +Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) +{ + dVAR; + const bool havepad = !!PL_comppad; + PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; + if (havepad) { + ENTER; + PAD_SAVE_SETNULLPAD(); + } + opslab_free(slab); + if (havepad) LEAVE; +} + +void +Perl_opslab_free(pTHX_ OPSLAB *slab) +{ + OPSLAB *slab2; + PERL_ARGS_ASSERT_OPSLAB_FREE; + assert(slab->opslab_refcnt == 1); + for (; slab; slab = slab2) { + slab2 = slab->opslab_next; +# ifdef DEBUGGING + slab->opslab_refcnt = ~(size_t)0; +# endif + PerlMemShared_free(slab); + } +} + +void +Perl_opslab_force_free(pTHX_ OPSLAB *slab) +{ + OPSLAB *slab2; + OPSLOT *slot; +# ifdef DEBUGGING + size_t savestack_count = 0; +# endif + PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; + slab2 = slab; + do { + for (slot = slab2->opslab_first; + slot->opslot_next; + slot = slot->opslot_next) { + if (slot->opslot_op.op_type != OP_FREED + && !(slot->opslot_op.op_savefree +# ifdef DEBUGGING + && ++savestack_count +# endif + ) + ) { + assert(slot->opslot_op.op_slabbed); + slab->opslab_refcnt++; /* op_free may free slab */ + op_free(&slot->opslot_op); + if (!--slab->opslab_refcnt) goto free; + } + } + } while ((slab2 = slab2->opslab_next)); + /* > 1 because the CV still holds a reference count. */ + if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */ +# ifdef DEBUGGING + assert(savestack_count == slab->opslab_refcnt-1); +# endif + return; + } + free: + opslab_free(slab); +} + #endif /* * In the following definition, the ", (OP*)0" is just to make the compiler @@ -316,7 +515,7 @@ Perl_Slab_Free(pTHX_ void *op) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC const char* +STATIC SV* S_gv_ename(pTHX_ GV *gv) { SV* const tmpsv = sv_newmortal(); @@ -324,7 +523,7 @@ S_gv_ename(pTHX_ GV *gv) PERL_ARGS_ASSERT_GV_ENAME; gv_efullname3(tmpsv, gv, NULL); - return SvPV_nolen_const(tmpsv); + return tmpsv; } STATIC OP * @@ -338,30 +537,57 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments(pTHX_ OP *o, const char *name) +S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) { - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS; + PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv), + SvUTF8(namesv) | flags); + return o; +} - yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name)); +STATIC OP * +S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) +{ + PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags); + return o; +} + +STATIC OP * +S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) +{ + PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV; + + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags); return o; } STATIC OP * -S_too_many_arguments(pTHX_ OP *o, const char *name) +S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) { - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS; + PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - yyerror(Perl_form(aTHX_ "Too many arguments for %s", name)); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), + SvUTF8(namesv) | flags); return o; } STATIC void -S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid) +S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { - PERL_ARGS_ASSERT_BAD_TYPE; + PERL_ARGS_ASSERT_BAD_TYPE_PV; - yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", - (int)n, name, t, OP_DESC(kid))); + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", + (int)n, name, t, OP_DESC(kid)), flags); +} + +STATIC void +S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid) +{ + PERL_ARGS_ASSERT_BAD_TYPE_SV; + + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", + (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags); } STATIC void @@ -400,17 +626,18 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) if (len && !(is_our || isALPHA(name[1]) || - ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) || + ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || (name[1] == '_' && (*name == '$' || len > 2)))) { /* name[2] is true if strlen(name) > 2 */ - if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { + if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) + && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) { yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", name[0], toCTRL(name[1]), (int)(len - 2), name + 2, PL_parser->in_my == KEY_state ? "state" : "my")); } else { - yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, - PL_parser->in_my == KEY_state ? "state" : "my")); + yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, + PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); } } @@ -436,6 +663,43 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) return off; } +/* +=for apidoc alloccopstash + +Available only under threaded builds, this function allocates an entry in +C for the stash passed to it. + +=cut +*/ + +#ifdef USE_ITHREADS +PADOFFSET +Perl_alloccopstash(pTHX_ HV *hv) +{ + PADOFFSET off = 0, o = 1; + bool found_slot = FALSE; + + PERL_ARGS_ASSERT_ALLOCCOPSTASH; + + if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix; + + for (; o < PL_stashpadmax; ++o) { + if (PL_stashpad[o] == hv) return PL_stashpadix = o; + if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV) + found_slot = TRUE, off = o; + } + if (!found_slot) { + Renew(PL_stashpad, PL_stashpadmax + 10, HV *); + Zero(PL_stashpad + PL_stashpadmax, 10, HV *); + off = PL_stashpadmax; + PL_stashpadmax += 10; + } + + PL_stashpad[PL_stashpadix = off] = hv; + return off; +} +#endif + /* free the body of an op without examining its contents. * Always use this rather than FreeOp directly */ @@ -463,7 +727,14 @@ Perl_op_free(pTHX_ OP *o) dVAR; OPCODE type; - if (!o) +#ifndef PL_OP_SLAB_ALLOC + /* Though ops may be freed twice, freeing the op after its slab is a + big no-no. */ + assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); +#endif + /* During the forced freeing of ops after compilation failure, kidops + may be freed before their parents. */ + if (!o || o->op_type == OP_FREED) return; if (o->op_latefreed) { if (o->op_latefree) @@ -676,6 +947,9 @@ Perl_op_clear(pTHX_ OP *o) case OP_MATCH: case OP_QR: clear_pmop: + 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; /* we use the same protection as the "SAFE" version of the PM_ macros @@ -712,7 +986,6 @@ S_cop_free(pTHX_ COP* cop) PERL_ARGS_ASSERT_COP_FREE; CopFILE_free(cop); - CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) PerlMemShared_free(cop->cop_warnings); cophh_free(CopHINTHASH_get(cop)); @@ -729,7 +1002,7 @@ S_forget_pmop(pTHX_ PMOP *const o PERL_ARGS_ASSERT_FORGET_PMOP; - if (pmstash && !SvIS_FREED(pmstash)) { + if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) { MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); if (mg) { PMOP **const array = (PMOP**) mg->mg_ptr; @@ -836,7 +1109,8 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) case G_ARRAY: return list(o); case G_VOID: return scalarvoid(o); default: - Perl_croak(aTHX_ "panic: op_contextualize bad context"); + Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", + (long) context); return o; } } @@ -1165,14 +1439,6 @@ Perl_scalarvoid(pTHX_ OP *o) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { - if (SvOK(sv)) { - SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ - "a constant (%"SVf")", sv)); - useless = SvPV_nolen(msv); - useless_is_utf8 = SvUTF8(msv); - } - else - useless = "a constant (undef)"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) @@ -1194,7 +1460,24 @@ Perl_scalarvoid(pTHX_ OP *o) strnEQ(maybe_macro, "ds", 2) || strnEQ(maybe_macro, "ig", 2)) useless = NULL; + else { + SV * const dsv = newSVpvs(""); + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%s)", + pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT ))); + SvREFCNT_dec(dsv); + useless = SvPV_nolen(msv); + useless_is_utf8 = SvUTF8(msv); + } + } + else if (SvOK(sv)) { + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%"SVf")", sv)); + useless = SvPV_nolen(msv); } + else + useless = "a constant (undef)"; } } op_null(o); /* don't execute or even remember it */ @@ -1614,9 +1897,10 @@ S_finalize_op(pTHX_ OP* o) key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { - Perl_croak(aTHX_ "No such class field \"%s\" " - "in variable %s of type %s", - key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname))); + Perl_croak(aTHX_ "No such class field \"%"SVf"\" " + "in variable %"SVf" of type %"HEKf, + SVfARG(*svp), SVfARG(lexname), + HEKfARG(HvNAME_HEK(SvSTASH(lexname)))); } break; } @@ -1669,9 +1953,10 @@ S_finalize_op(pTHX_ OP* o) key = SvPV_const(*svp, keylen); if (!hv_fetch(GvHV(*fields), key, SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { - Perl_croak(aTHX_ "No such class field \"%s\" " - "in variable %s of type %s", - key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname))); + Perl_croak(aTHX_ "No such class field \"%"SVf"\" " + "in variable %"SVf" of type %"HEKf, + SVfARG(*svp), SVfARG(lexname), + HEKfARG(HvNAME_HEK(SvSTASH(lexname)))); } } break; @@ -1730,9 +2015,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID ); + if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; + switch (o->op_type) { case OP_UNDEF: - localize = 0; PL_modcount++; return o; case OP_STUB: @@ -1756,14 +2042,13 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV)); PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { - /* Backward compatibility mode: */ + /* Potential lvalue context: */ o->op_private |= OPpENTERSUB_INARGS; break; } else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; - OP *okid; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -1776,33 +2061,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) while (kid->op_sibling) kid = kid->op_sibling; if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { - /* Indirect call */ - if (kid->op_type == OP_METHOD_NAMED - || kid->op_type == OP_METHOD) - { - UNOP *newop; - - NewOp(1101, newop, 1, UNOP); - newop->op_type = OP_RV2CV; - newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; - newop->op_first = NULL; - newop->op_next = (OP*)newop; - kid->op_sibling = (OP*)newop; - newop->op_private |= OPpLVAL_INTRO; - newop->op_private &= ~1; - break; - } - - if (kid->op_type != OP_RV2CV) - Perl_croak(aTHX_ - "panic: unexpected lvalue entersub " - "entry via type/targ %ld:%"UVuf, - (long)kid->op_type, (UV)kid->op_targ); - kid->op_private |= OPpLVAL_INTRO; break; /* Postpone until runtime */ } - okid = kid; kid = kUNOP->op_first; if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) kid = kUNOP->op_first; @@ -1812,25 +2073,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { - /* Restore RV2CV to check lvalueness */ - restore_2cv: - if (kid->op_next && kid->op_next != kid) { /* Happens? */ - okid->op_next = kid->op_next; - kid->op_next = okid; - } - else - okid->op_next = NULL; - okid->op_type = OP_RV2CV; - okid->op_targ = 0; - okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; - okid->op_private |= OPpLVAL_INTRO; - okid->op_private &= ~1; break; } cv = GvCV(kGVOP_gv); if (!cv) - goto restore_2cv; + break; if (CvLVALUE(cv)) break; } @@ -2018,6 +2266,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if (type != OP_LEAVESUBLV) goto nomod; break; /* op_lvalue()ing was handled by ck_return() */ + + case OP_COREARGS: + return o; } /* [20011101.069] File test operators interpret OPf_REF to mean that @@ -2055,11 +2306,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) STATIC bool S_scalar_mod_type(const OP *o, I32 type) { - assert(o || type != OP_SASSIGN); - switch (type) { + case OP_POS: case OP_SASSIGN: - if (o->op_type == OP_RV2GV) + if (o && o->op_type == OP_RV2GV) return FALSE; /* FALL THROUGH */ case OP_PREINC: @@ -2425,11 +2675,8 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my_kid(kid, attrs, imopsp); - } else if (type == OP_UNDEF -#ifdef PERL_MAD - || type == OP_STUB -#endif - ) { + return o; + } else if (type == OP_UNDEF || type == OP_STUB) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || @@ -2567,7 +2814,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) && (gv = cGVOPx_gv(cUNOPx(left)->op_first)) ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1) : NULL - : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1); + : varname( + (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1 + ); if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %"SVf" will act on scalar(%"SVf")", @@ -2625,7 +2874,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) } else return bind_match(type, left, - pmruntime(newPMOP(OP_MATCH, 0), right, 0)); + pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0)); } OP * @@ -2761,6 +3010,7 @@ Perl_newPROG(pTHX_ OP *o) if (PL_in_eval) { PERL_CONTEXT *cx; + I32 i; if (PL_eval_root) return; PL_eval_root = newUNOP(OP_LEAVEEVAL, @@ -2777,16 +3027,17 @@ Perl_newPROG(pTHX_ OP *o) 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); PL_eval_root->op_next = 0; + i = PL_savestack_ix; + SAVEFREEOP(o); + ENTER; CALL_PEEP(PL_eval_start); finalize_optree(PL_eval_root); - + LEAVE; + PL_savestack_ix = i; } else { if (o->op_type == OP_STUB) { @@ -2803,6 +3054,9 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_next = 0; CALL_PEEP(PL_main_start); finalize_optree(PL_main_root); +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(PL_compcv); +#endif PL_compcv = 0; /* Register with debugger */ @@ -2966,9 +3220,11 @@ S_fold_constants(pTHX_ register OP *o) case OP_SCMP: case OP_SPRINTF: /* XXX what about the numeric ops? */ - if (PL_hints & HINT_LOCALE) + if (IN_LOCALE_COMPILETIME) goto nope; break; + case OP_REPEAT: + if (o->op_private & OPpREPEAT_DOLIST) goto nope; } if (PL_parser && PL_parser->error_count) @@ -3978,9 +4234,6 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; - PerlMemShared_free(cPVOPo->op_pv); - cPVOPo->op_pv = NULL; - swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); #ifdef USE_ITHREADS cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); @@ -4014,9 +4267,12 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) return o; } - tbl = (short*)cPVOPo->op_pv; + tbl = (short*)PerlMemShared_calloc( + (o->op_private & OPpTRANS_COMPLEMENT) && + !(o->op_private & OPpTRANS_DELETE) ? 258 : 256, + sizeof(short)); + cPVOPo->op_pv = (char*)tbl; if (complement) { - Zero(tbl, 256, short); for (i = 0; i < (I32)tlen; i++) tbl[t[i]] = -1; for (i = 0, j = 0; i < 256; i++) { @@ -4129,10 +4385,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; - if (PL_hints & HINT_LOCALE) { + if (IN_LOCALE_COMPILETIME) { set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); } - else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) { + else if ((! (PL_hints & HINT_BYTES)) + /* Both UNI_8_BIT and locale :not_characters imply Unicode */ + && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS))) + { set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { @@ -4185,25 +4444,29 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/) or if it contains * a replacement, ie s/// or tr///. + * + * When the pattern has been compiled within a new anon CV (for + * qr/(?{...})/ ), then floor indicates the savestack level just before + * the new sub was created */ OP * -Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) +Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) { dVAR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; OP* repl = NULL; - bool reglist; + bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); + bool is_compiletime; + bool has_code; PERL_ARGS_ASSERT_PMRUNTIME; - if ( - o->op_type == OP_SUBST - || o->op_type == OP_TRANS || o->op_type == OP_TRANSR - ) { - /* last element in list is the replacement; pop it */ + /* for s/// and tr///, last element in list is the replacement; pop it */ + + if (is_trans || o->op_type == OP_SUBST) { OP* kid; repl = cLISTOPx(expr)->op_last; kid = cLISTOPx(expr)->op_first; @@ -4213,60 +4476,230 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) cLISTOPx(expr)->op_last = kid; } - if (isreg && expr->op_type == OP_LIST && - cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last) - { - /* convert single element list to element */ + /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */ + + if (is_trans) { OP* const oe = expr; - expr = cLISTOPx(oe)->op_first->op_sibling; + assert(expr->op_type == OP_LIST); + assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK); + assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last); + expr = cLISTOPx(oe)->op_last; cLISTOPx(oe)->op_first->op_sibling = NULL; cLISTOPx(oe)->op_last = NULL; op_free(oe); - } - if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) { return pmtrans(o, expr, repl); } - reglist = isreg && expr->op_type == OP_LIST; - if (reglist) - op_null(expr); + /* 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)) { + 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; + + LINKLIST(expr); + + /* fix up DO blocks; treat each one as a separate little sub */ + + 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))) + 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 { + /* 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); + } + /* 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); + } + } PL_hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; + assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); - if (expr->op_type == OP_CONST) { - SV *pat = ((SVOP*)expr)->op_sv; - U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; + if (is_compiletime) { + 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; - - 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)); + rx_flags |= RXf_SPLIT; + + if (!has_code || !eng->op_comp) { + /* compile-time simple constant pattern */ + + if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { + /* whoops! we guessed that a qr// had a code block, but we + * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv + * that isn't required now. Note that we have to be pretty + * confident that nothing used that CV's pad while the + * regex was parsed */ + assert(AvFILLp(PL_comppad) == 0); /* just @_ */ +#ifndef PL_OP_SLAB_ALLOC + /* But we know that one op is using this CV's slab. */ + cv_forget_slab(PL_compcv); +#endif + LEAVE_SCOPE(floor); + pm->op_pmflags &= ~PMf_HAS_CV; + } + 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'); + op_getmad(expr,(OP*)pm,'e'); #else - op_free(expr); + op_free(expr); +#endif + } + else { + /* compile-time pattern that includes literal code blocks */ + 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; + /* this QR op (and the anon sub we embed it in) is never + * actually executed. It's just a placeholder where we can + * squirrel away expr in op_code_list without the peephole + * optimiser etc processing it for a second time */ + OP *qr = newPMOP(OP_QR, 0); + ((PMOP*)qr)->op_code_list = expr; + + /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ + SvREFCNT_inc_simple_void(PL_compcv); + cv = newATTRSUB(floor, 0, NULL, NULL, qr); + ((struct regexp *)SvANY(re))->qr_anoncv = cv; + + /* attach the anon CV to the pad so that + * pad_fixup_inner_anons() can find it */ + (void)pad_add_anon(cv, o->op_type); + SvREFCNT_inc_simple_void(cv); + +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(cv); #endif + } + else { + pm->op_code_list = expr; + } + } } else { - if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) - expr = newUNOP((!(PL_hints & HINT_RE_EVAL) - ? OP_REGCRESET - : OP_REGCMAYBE),0,expr); + /* 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 (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 + * that the qr// has been wrapped in a new CV, which + * means that runtime consts, vars etc will have been compiled + * against a new pad. So... we need to execute those ops + * within the environment of the new CV. So wrap them in a call + * to a new anon sub. i.e. for + * + * qr/a$b(?{...})/, + * + * we build an anon sub that looks like + * + * sub { "a", $b, '(?{...})' } + * + * and call it, passing the returned list to regcomp. + * Or to put it another way, the list of ops that get executed + * are: + * + * normal PMf_HAS_CV + * ------ ------------------- + * pushmark (for regcomp) + * pushmark (for entersub) + * pushmark (for refgen) + * anoncode + * refgen + * entersub + * regcreset regcreset + * pushmark pushmark + * const("a") const("a") + * gvsv(b) gvsv(b) + * const("(?{...})") const("(?{...})") + * leavesub + * regcomp regcomp + */ + + SvREFCNT_inc_simple_void(PL_compcv); + /* 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_type = OP_REGCOMP; @@ -4275,16 +4708,15 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) 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; /* establish postfix order */ - if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { + if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) { LINKLIST(expr); rcop->op_next = expr; ((UNOP*)expr)->op_first->op_next = (OP*)rcop; @@ -4502,8 +4934,11 @@ OP * Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { dVAR; + const bool utf8 = cBOOL(flags & SVf_UTF8); PVOP *pvop; + flags &= ~SVf_UTF8; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP || type == OP_RUNCV || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); @@ -4514,6 +4949,7 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) pvop->op_pv = pv; pvop->op_next = (OP*)pvop; pvop->op_flags = (U8)flags; + pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)pvop); if (PL_opargs[type] & OA_TARGET) @@ -4585,7 +5021,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 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; @@ -4669,50 +5105,28 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) newSTATEOP(0, NULL, imop) )); if (use_version) { - HV * const hinthv = GvHV(PL_hintgv); - const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH); - - /* Turn features off */ - if (hhoff) - /* avoid loading feature.pm */ - PL_hints &= ~HINT_UNI_8_BIT; - else { - ENTER_with_name("load_feature"); - Perl_load_module(aTHX_ - PERL_LOADMOD_DENY, newSVpvs("feature"), NULL, NULL - ); - } - - /* If we request a version >= 5.9.5, load feature.pm with the + /* Enable the * feature bundle that corresponds to the required version. */ use_version = sv_2mortal(new_version(use_version)); + S_enable_feature_bundle(aTHX_ use_version); - if (vcmp(use_version, - sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { - SV *const importsv = vnormal(use_version); - if (hhoff) ENTER_with_name("load_feature"); - *SvPVX_mutable(importsv) = ':'; - Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); - LEAVE_with_name("load_feature"); - } - else if (!hhoff) LEAVE_with_name("load_feature"); /* If a version >= 5.11.0 is requested, strictures are on by default! */ if (vcmp(use_version, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { - if (hhoff || !hv_exists(hinthv, "strict/refs", 11)) + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) PL_hints |= HINT_STRICT_REFS; - if (hhoff || !hv_exists(hinthv, "strict/subs", 11)) + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) PL_hints |= HINT_STRICT_SUBS; - if (hhoff || !hv_exists(hinthv, "strict/vars", 11)) + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) PL_hints |= HINT_STRICT_VARS; } /* otherwise they are off */ else { - if (hhoff || !hv_exists(hinthv, "strict/refs", 11)) + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) PL_hints &= ~HINT_STRICT_REFS; - if (hhoff || !hv_exists(hinthv, "strict/subs", 11)) + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) PL_hints &= ~HINT_STRICT_SUBS; - if (hhoff || !hv_exists(hinthv, "strict/vars", 11)) + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) PL_hints &= ~HINT_STRICT_VARS; } } @@ -4742,11 +5156,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) 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 } @@ -4760,7 +5169,7 @@ Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS -(or 0 for no flags). ver, if specified, provides version semantics +(or 0 for no flags). ver, if specified and not NULL, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. They must be @@ -4769,6 +5178,8 @@ be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. Otherwise at least a single NULL pointer to designate the default import list is required. +The reference count for each specified C parameter is decremented. + =cut */ void @@ -4859,10 +5270,10 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) } if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { - doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + doop = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv)))))); + newGVOP(OP_GV, 0, gv))))); } else { doop = newUNOP(OP_DOFILE, 0, scalar(term)); @@ -5227,8 +5638,11 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { dVAR; const U32 seq = intro_my(); + const U32 utf8 = flags & SVf_UTF8; register COP *cop; + flags &= ~SVf_UTF8; + NewOp(1101, cop, 1, COP); if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { cop->op_type = OP_DBSTATE; @@ -5250,8 +5664,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); if (label) { - Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0); - + Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); + PL_hints |= HINT_BLOCK_SCOPE; /* It seems that we need to defer freeing this pointer, as other parts of the grammar end up wanting to copy it after this op has been @@ -5711,6 +6125,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR || expr->op_type == OP_GLOB + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); @@ -5800,6 +6215,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR || expr->op_type == OP_GLOB + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); @@ -6016,7 +6432,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) /* for my $x () sets OPpLVAL_INTRO; * for our $x () sets OPpOUR_INTRO */ loop->op_private = (U8)iterpflags; -#ifdef PL_OP_SLAB_ALLOC +#ifndef PL_OP_SLAB_ALLOC + if (DIFF(loop, OpSLOT(loop)->opslot_next) + < SIZE_TO_PSIZE(sizeof(LOOP))) +#endif { LOOP *tmp; NewOp(1234,tmp,1,LOOP); @@ -6024,9 +6443,6 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } -#else - loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); -#endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); if (madsv) @@ -6055,14 +6471,19 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); - if (type != OP_GOTO || label->op_type == OP_CONST) { + if (type != OP_GOTO) { /* "last()" means "last" */ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) o = newOP(type, OPf_SPECIAL); else { - o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST - ? SvPV_nolen_const(((SVOP*)label)->op_sv) - : "")); + const_label: + o = newPVOP(type, + label->op_type == OP_CONST + ? SvUTF8(((SVOP*)label)->op_sv) + : 0, + savesharedpv(label->op_type == OP_CONST + ? SvPV_nolen_const(((SVOP*)label)->op_sv) + : "")); } #ifdef PERL_MAD op_getmad(label,o,'L'); @@ -6075,6 +6496,12 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) if (label->op_type == OP_ENTERSUB && !(label->op_flags & OPf_STACKED)) label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); + else if (label->op_type == OP_CONST) { + SV * const sv = ((SVOP *)label)->op_sv; + STRLEN l; + const char *s = SvPV_const(sv,l); + if (l == strlen(s)) goto const_label; + } o = newUNOP(type, OPf_STACKED, label); } PL_hints |= HINT_BLOCK_SCOPE; @@ -6152,6 +6579,7 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, /* This is a default {} block */ enterop->op_first = block; enterop->op_flags |= OPf_SPECIAL; + o ->op_flags |= OPf_SPECIAL; o->op_next = (OP *) enterop; } @@ -6488,6 +6916,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { + return newATTRSUB_flags(floor, o, proto, attrs, block, 0); +} + +CV * +Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, U32 flags) +{ dVAR; GV *gv; const char *ps; @@ -6495,19 +6930,23 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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; - const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL; + const bool o_is_gv = flags & 1; + const char * const name = + o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; - bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0; + bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -6517,7 +6956,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (name) { + if (o_is_gv) { + gv = (GV*)o; + o = NULL; + has_name = TRUE; + } else if (name) { gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { @@ -6544,14 +6987,30 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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 (!SvPOK((const SV *)gv) - && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)) - { - Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); - } cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8); } if (ps) { @@ -6631,10 +7090,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } if (const_sv) { - HV *stash; SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(cv); +#endif sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; @@ -6648,14 +7109,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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); @@ -6673,6 +7126,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; AV *const temp_av = CvPADLIST(cv); CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t slabbed = CvSLABBED(cv); + OP * const cvstart = CvSTART(cv); assert(!CvWEAKOUTSIDE(cv)); assert(!CvCVGV_RC(cv)); @@ -6685,6 +7140,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvPADLIST(cv) = CvPADLIST(PL_compcv); CvOUTSIDE(PL_compcv) = temp_cv; CvPADLIST(PL_compcv) = temp_av; + CvSTART(cv) = CvSTART(PL_compcv); + CvSTART(PL_compcv) = cvstart; + if (slabbed) CvSLABBED_on(PL_compcv); + else CvSLABBED_off(PL_compcv); if (CvFILE(cv) && CvDYNFILE(cv)) { Safefree(CvFILE(cv)); @@ -6733,25 +7192,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *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; @@ -6779,6 +7219,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); CvROOT(cv)->op_private |= OPpREFCOUNTED; OpREFCNT_set(CvROOT(cv), 1); +#ifndef PL_OP_SLAB_ALLOC + /* The cv no longer needs to hold a refcount on the slab, as CvROOT + itself has a refcount. */ + CvSLABBED_off(cv); + OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); +#endif CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); @@ -6882,6 +7328,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); @@ -6891,6 +7338,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); @@ -6966,9 +7414,7 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, if (stash) { SAVEGENERICSV(PL_curstash); - SAVECOPSTASH(PL_curcop); PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); - CopSTASH_set(PL_curcop,stash); } /* file becomes the CvFILE. For an XS, it's usually static storage, @@ -6980,10 +7426,6 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); -#ifdef USE_ITHREADS - if (stash) - CopSTASH_free(PL_curcop); -#endif LEAVE; return cv; @@ -7080,6 +7522,23 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, 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 @@ -7093,7 +7552,9 @@ CV * Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) { PERL_ARGS_ASSERT_NEWXS; - return newXS_flags(name, subaddr, filename, NULL, 0); + return newXS_len_flags( + name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 + ); } #ifdef PERL_MAD @@ -7123,6 +7584,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); } else { + /* diag_listed_as: Format %s redefined */ Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format STDOUT redefined"); } @@ -7144,6 +7606,9 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); +#ifndef PL_OP_SLAB_ALLOC + cv_forget_slab(cv); +#endif #ifdef PERL_MAD op_getmad(o,pegop,'n'); op_getmad_weak(block, pegop, 'b'); @@ -7364,8 +7829,12 @@ Perl_ck_cmp(pTHX_ OP *o) if (ckWARN(WARN_SYNTAX)) { const OP *kid = cUNOPo->op_first; if (kid && ( - is_dollar_bracket(aTHX_ kid) - || ((kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) + ( + is_dollar_bracket(aTHX_ kid) + && kid->op_sibling && kid->op_sibling->op_type == OP_CONST + ) + || ( kid->op_type == OP_CONST + && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) )) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "$[ used in %s (did you mean $] ?)", OP_DESC(o)); @@ -7470,6 +7939,7 @@ Perl_ck_eof(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { + OP *kid; if (cLISTOPo->op_first->op_type == OP_STUB) { OP * const newop = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); @@ -7480,7 +7950,10 @@ Perl_ck_eof(pTHX_ OP *o) #endif o = newop; } - return ck_fun(o); + o = ck_fun(o); + kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) + kid->op_private |= OPpALLOW_FAKE; } return o; } @@ -7550,11 +8023,10 @@ Perl_ck_eval(pTHX_ OP *o) MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv)))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; - - if (!(o->op_private & OPpEVAL_BYTES) - && FEATURE_IS_ENABLED("unieval")) - o->op_private |= OPpEVAL_UNICODE; } + if (!(o->op_private & OPpEVAL_BYTES) + && FEATURE_UNIEVAL_IS_ENABLED) + o->op_private |= OPpEVAL_UNICODE; return o; } @@ -7760,6 +8232,11 @@ Perl_ck_ftst(pTHX_ OP *o) && kidtype != OP_STAT && kidtype != OP_LSTAT) { o->op_private |= OPpFT_STACKED; kid->op_private |= OPpFT_STACKING; + if (kidtype == OP_FTTTY && ( + !(kid->op_private & OPpFT_STACKED) + || kid->op_private & OPpFT_AFTER_t + )) + o->op_private |= OPpFT_AFTER_t; } } else { @@ -7839,7 +8316,7 @@ Perl_ck_fun(pTHX_ OP *o) if (numargs == 1 && !(oa >> 4) && kid->op_type == OP_LIST && type != OP_SCALAR) { - return too_many_arguments(o,PL_op_desc[type]); + return too_many_arguments_pv(o,PL_op_desc[type], 0); } scalar(kid); break; @@ -7879,7 +8356,7 @@ Perl_ck_fun(pTHX_ OP *o) && ( !SvROK(cSVOPx_sv(kid)) || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) ) - bad_type(numargs, "array", PL_op_desc[type], kid); + bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid); /* Defer checks to run-time if we have a scalar arg */ if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV) op_lvalue(kid, type); @@ -7904,7 +8381,7 @@ Perl_ck_fun(pTHX_ OP *o) *tokid = kid; } else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type(numargs, "hash", PL_op_desc[type], kid); + bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid); op_lvalue(kid, type); break; case OA_CVREF: @@ -7937,7 +8414,7 @@ Perl_ck_fun(pTHX_ OP *o) } else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(), close() etc. */ - bad_type(numargs, "HANDLE", OP_DESC(o), kid); + bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid); } else { I32 flags = OPf_SPECIAL; @@ -7949,6 +8426,7 @@ Perl_ck_fun(pTHX_ OP *o) const char *name = NULL; STRLEN len = 0; U32 name_utf8 = 0; + bool want_dollar = TRUE; flags = 0; /* Set a flag to tell rv2gv to vivify @@ -8015,6 +8493,7 @@ Perl_ck_fun(pTHX_ OP *o) if (!name) { name = "__ANONIO__"; len = 10; + want_dollar = FALSE; } op_lvalue(kid, type); } @@ -8023,7 +8502,7 @@ Perl_ck_fun(pTHX_ OP *o) targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PAD_SVl(targ); SvUPGRADE(namesv, SVt_PV); - if (*name != '$') + if (want_dollar && *name != '$') sv_setpvs(namesv, "$"); sv_catpvn(namesv, name, len); if ( name_utf8 ) SvUTF8_on(namesv); @@ -8040,6 +8519,10 @@ Perl_ck_fun(pTHX_ OP *o) scalar(kid); break; case OA_SCALARREF: + if ((type == OP_UNDEF || type == OP_POS) + && numargs == 1 && !(oa >> 4) + && kid->op_type == OP_LIST) + return too_many_arguments_pv(o,PL_op_desc[type], 0); op_lvalue(scalar(kid), type); break; } @@ -8049,13 +8532,13 @@ Perl_ck_fun(pTHX_ OP *o) } #ifdef PERL_MAD if (kid && kid->op_type != OP_STUB) - return too_many_arguments(o,OP_DESC(o)); + return too_many_arguments_pv(o,OP_DESC(o), 0); o->op_private |= numargs; #else /* FIXME - should the numargs move as for the PERL_MAD case? */ o->op_private |= numargs; if (kid) - return too_many_arguments(o,OP_DESC(o)); + return too_many_arguments_pv(o,OP_DESC(o), 0); #endif listkids(o); } @@ -8075,7 +8558,7 @@ Perl_ck_fun(pTHX_ OP *o) while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) - return too_few_arguments(o,OP_DESC(o)); + return too_few_arguments_pv(o,OP_DESC(o), 0); } return o; } @@ -8097,18 +8580,11 @@ Perl_ck_glob(pTHX_ OP *o) else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) && GvCVu(gv) && GvIMPORTED_CV(gv))) { - gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); + GV * const * const gvp = + (GV **)hv_fetchs(PL_globalstash, "glob", FALSE); + gv = gvp ? *gvp : NULL; } -#if !defined(PERL_EXTERNAL_GLOB) - if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { - ENTER; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvs("File::Glob"), NULL, NULL, NULL); - LEAVE; - } -#endif /* !PERL_EXTERNAL_GLOB */ - if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { /* convert * glob @@ -8131,11 +8607,19 @@ Perl_ck_glob(pTHX_ OP *o) op_append_elem(OP_LIST, o, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); - o = newUNOP(OP_NULL, 0, ck_subr(o)); + o = newUNOP(OP_NULL, 0, o); o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ return o; } else o->op_flags &= ~OPf_SPECIAL; +#if !defined(PERL_EXTERNAL_GLOB) + if (!PL_globhook) { + ENTER; + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs("File::Glob"), NULL, NULL, NULL); + LEAVE; + } +#endif /* !PERL_EXTERNAL_GLOB */ gv = newGVgen("main"); gv_IOadd(gv); #ifndef PERL_EXTERNAL_GLOB @@ -8183,7 +8667,7 @@ Perl_ck_grep(pTHX_ OP *o) return o; kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_grep"); + Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; if (!gwop) @@ -8206,7 +8690,7 @@ Perl_ck_grep(pTHX_ OP *o) kid = cLISTOPo->op_first->op_sibling; if (!kid || !kid->op_sibling) - return too_few_arguments(o,OP_DESC(o)); + return too_few_arguments_pv(o,OP_DESC(o), 0); for (kid = kid->op_sibling; kid; kid = kid->op_sibling) op_lvalue(kid, OP_GREPSTART); @@ -8249,11 +8733,6 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ if ((o->op_flags & OPf_KIDS)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: - /* This is needed for - if (defined %stash::) - to work. Do not break Tk. - */ - break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), @@ -8281,7 +8760,11 @@ Perl_ck_readline(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_READLINE; - if (!(o->op_flags & OPf_KIDS)) { + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + } + else { OP * const newop = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); #ifdef PERL_MAD @@ -8333,6 +8816,7 @@ Perl_ck_listiob(pTHX_ OP *o) if (!kid) op_append_elem(o->op_type, o, newDEFSVOP()); + if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF); return listkids(o); } @@ -8638,11 +9122,11 @@ Perl_ck_require(pTHX_ OP *o) #ifndef PERL_MAD op_free(o); #endif - newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + newop = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, kid, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, - gv)))))); + gv))))); op_getmad(o,newop,'O'); return newop; } @@ -8790,8 +9274,6 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = k; o->op_flags |= OPf_SPECIAL; } - else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - op_null(firstkid); firstkid = firstkid->op_sibling; } @@ -8893,7 +9375,7 @@ Perl_ck_split(pTHX_ OP *o) kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_split"); + Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); kid = kid->op_sibling; op_free(cLISTOPo->op_first); if (kid) @@ -8906,7 +9388,7 @@ Perl_ck_split(pTHX_ OP *o) if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP * const sibl = kid->op_sibling; kid->op_sibling = 0; - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0); + kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); if (cLISTOPo->op_first == cLISTOPo->op_last) cLISTOPo->op_last = kid; cLISTOPo->op_first = kid; @@ -8935,7 +9417,7 @@ Perl_ck_split(pTHX_ OP *o) scalar(kid); if (kid->op_sibling) - return too_many_arguments(o,OP_DESC(o)); + return too_many_arguments_pv(o,OP_DESC(o), 0); return o; } @@ -8950,11 +9432,13 @@ Perl_ck_join(pTHX_ OP *o) if (kid && kid->op_type == OP_MATCH) { if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); - const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING"; - const STRLEN len = re ? RX_PRELEN(re) : 6; + const SV *msg = re + ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re), + SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) ) + : newSVpvs_flags( "STRING", SVs_TEMP ); Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "/%.*s/ should probably be written as \"%.*s\"", - (int)len, pmstr, (int)len, pmstr); + "/%"SVf"/ should probably be written as \"%"SVf"\"", + SVfARG(msg), SVfARG(msg)); } } return ck_fun(o); @@ -9117,7 +9601,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) const char *e = NULL; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) - Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto"); + Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " + "flags=%lx", (unsigned long) SvFLAGS(protosv)); if (SvTYPE(protosv) == SVt_PVCV) proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); else proto = SvPV(protosv, proto_len); @@ -9140,7 +9625,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) o3 = aop; if (proto >= proto_end) - return too_many_arguments(entersubop, gv_ename(namegv)); + return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); switch (*proto) { case ';': @@ -9149,7 +9634,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; case '_': /* _ must be at the end */ - if (proto[1] && proto[1] != ';') + if (proto[1] && !strchr(";@%", proto[1])) goto oops; case '$': proto++; @@ -9165,9 +9650,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) proto++; arg++; if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) - bad_type(arg, + bad_type_sv(arg, arg == 1 ? "block or sub {}" : "sub {}", - gv_ename(namegv), o3); + gv_ename(namegv), 0, o3); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -9252,9 +9737,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type(arg, Perl_form(aTHX_ "one of %.*s", + bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s", (int)(end - p), p), - gv_ename(namegv), o3); + gv_ename(namegv), 0, o3); } else goto oops; break; @@ -9262,13 +9747,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (o3->op_type == OP_RV2GV) goto wrapref; if (!contextclass) - bad_type(arg, "symbol", gv_ename(namegv), o3); + bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3); break; case '&': if (o3->op_type == OP_ENTERSUB) goto wrapref; if (!contextclass) - bad_type(arg, "subroutine entry", gv_ename(namegv), + bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0, o3); break; case '$': @@ -9284,7 +9769,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type(arg, "scalar", gv_ename(namegv), o3); + bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3); } break; case '@': @@ -9292,14 +9777,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) o3->op_type == OP_PADAV) goto wrapref; if (!contextclass) - bad_type(arg, "array", gv_ename(namegv), o3); + bad_type_sv(arg, "array", gv_ename(namegv), 0, o3); break; case '%': if (o3->op_type == OP_RV2HV || o3->op_type == OP_PADHV) goto wrapref; if (!contextclass) - bad_type(arg, "hash", gv_ename(namegv), o3); + bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3); break; wrapref: { @@ -9344,7 +9829,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments(entersubop, gv_ename(namegv)); + return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); return entersubop; } @@ -9402,10 +9887,9 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) { aop = aop->op_sibling; - continue; } if (aop != cvop) - (void)too_many_arguments(entersubop, GvNAME(namegv)); + (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); op_free(entersubop); switch(GvNAME(namegv)[2]) { @@ -9466,7 +9950,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) #ifdef PERL_MAD if (!PL_madskills || seenarg) #endif - (void)too_many_arguments(aop, GvNAME(namegv)); + (void)too_many_arguments_pv(aop, GvNAME(namegv), 0); op_free(aop); } return opnum == OP_RUNCV @@ -9573,6 +10057,7 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } + callmg->mg_flags |= MGf_COPY; } } @@ -9686,6 +10171,19 @@ Perl_ck_substr(pTHX_ OP *o) } OP * +Perl_ck_tell(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_TELL; + o = ck_fun(o); + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling; + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + } + return o; +} + +OP * Perl_ck_each(pTHX_ OP *o) { dVAR; @@ -9742,7 +10240,8 @@ Perl_ck_length(pTHX_ OP *o) case OP_PADHV: case OP_PADAV: name = varname( - NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1 + (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ, + NULL, 0, 1 ); break; case OP_RV2HV: @@ -9830,7 +10329,7 @@ S_inplace_aassign(pTHX_ OP *o) { return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - oright = cUNOPx(modop)->op_first->op_sibling; + if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; if (modop->op_flags & OPf_STACKED) { /* skip sort subroutine/block */ @@ -9955,7 +10454,7 @@ Perl_rpeep(pTHX_ register OP *o) data. */ firstcop->cop_line = secondcop->cop_line; #ifdef USE_ITHREADS - firstcop->cop_stashpv = secondcop->cop_stashpv; + firstcop->cop_stashoff = secondcop->cop_stashoff; firstcop->cop_file = secondcop->cop_file; #else firstcop->cop_stash = secondcop->cop_stash; @@ -9967,7 +10466,7 @@ Perl_rpeep(pTHX_ register OP *o) firstcop->cop_hints_hash = secondcop->cop_hints_hash; #ifdef USE_ITHREADS - secondcop->cop_stashpv = NULL; + secondcop->cop_stashoff = 0; secondcop->cop_file = NULL; #else secondcop->cop_stash = NULL; @@ -10318,7 +10817,7 @@ Perl_rpeep(pTHX_ register OP *o) case OP_RUNCV: if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) { SV *sv; - if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef; + if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; else { sv = newRV((SV *)PL_compcv); sv_rvweaken(sv); @@ -10462,7 +10961,7 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) This function assigns the prototype of the named core function to C, or to a new mortal SV if C is NULL. It returns the modified C, or NULL if the core function has no prototype. C is a code as returned -by C. It must be negative and unequal to -KEY_CORE. +by C. It must not be equal to 0 or -KEY_CORE. =cut */ @@ -10479,19 +10978,24 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, PERL_ARGS_ASSERT_CORE_PROTOTYPE; - assert (code < 0 && code != -KEY_CORE); + assert (code && code != -KEY_CORE); if (!sv) sv = sv_newmortal(); #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv - switch (-code) { + switch (code < 0 ? -code : code) { case KEY_and : case KEY_chop: case KEY_chomp: - case KEY_cmp : case KEY_exec: case KEY_eq : - case KEY_ge : case KEY_gt : case KEY_le : - case KEY_lt : case KEY_ne : case KEY_or : - case KEY_select: case KEY_system: case KEY_x : case KEY_xor: + case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec : + case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto : + case KEY_grep : case KEY_gt : case KEY_last : case KEY_le : + case KEY_lt : case KEY_map : case KEY_ne : case KEY_next : + case KEY_or : case KEY_print : case KEY_printf: case KEY_qr : + case KEY_redo : case KEY_require: case KEY_return: case KEY_say : + case KEY_select: case KEY_sort : case KEY_split : case KEY_system: + case KEY_x : case KEY_xor : if (!opnum) return NULL; nullret = TRUE; goto findopnum; + case KEY_glob: retsetpvs("_;", OP_GLOB); case KEY_keys: retsetpvs("+", OP_KEYS); case KEY_values: retsetpvs("+", OP_VALUES); case KEY_each: retsetpvs("+", OP_EACH); @@ -10499,6 +11003,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, case KEY_unshift: retsetpvs("+@", OP_UNSHIFT); case KEY_pop: retsetpvs(";+", OP_POP); case KEY_shift: retsetpvs(";+", OP_SHIFT); + case KEY_pos: retsetpvs(";\\[$*]", OP_POS); case KEY_splice: retsetpvs("+;$$@", OP_SPLICE); case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: @@ -10521,7 +11026,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, } i++; } - assert(0); return NULL; /* Should not happen... */ + return NULL; found: defgv = PL_opargs[i] & OA_DEFGV; oa = PL_opargs[i] >> OASHIFT; @@ -10545,7 +11050,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, str[n++] = '$'; str[n++] = '@'; str[n++] = '%'; - if (i == OP_LOCK) str[n++] = '&'; + if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; str[n++] = '*'; str[n++] = ']'; } @@ -10613,14 +11118,14 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, onearg: if (is_handle_constructor(o, 1)) argop->op_private |= OPpCOREARGS_DEREF1; + if (scalar_mod_type(NULL, opnum)) + argop->op_private |= OPpCOREARGS_SCALARMOD; } return o; default: - o = convert(opnum,0,argop); + o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); if (is_handle_constructor(o, 2)) argop->op_private |= OPpCOREARGS_DEREF2; - if (scalar_mod_type(NULL, opnum)) - argop->op_private |= OPpCOREARGS_SCALARMOD; if (opnum == OP_SUBSTR) { o->op_private |= OPpMAYBE_LVSUB; return o; @@ -10669,6 +11174,71 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, name); } +/* +=head1 Hook manipulation + +These functions provide convenient and thread-safe means of manipulating +hook variables. + +=cut +*/ + +/* +=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p + +Puts a C function into the chain of check functions for a specified op +type. This is the preferred way to manipulate the L array. +I specifies which type of op is to be affected. I +is a pointer to the C function that is to be added to that opcode's +check chain, and I points to the storage location where a +pointer to the next function in the chain will be stored. The value of +I is written into the L array, while the value +previously stored there is written to I<*old_checker_p>. + +L is global to an entire process, and a module wishing to +hook op checking may find itself invoked more than once per process, +typically in different threads. To handle that situation, this function +is idempotent. The location I<*old_checker_p> must initially (once +per process) contain a null pointer. A C variable of static duration +(declared at file scope, typically also marked C to give +it internal linkage) will be implicitly initialised appropriately, +if it does not have an explicit initialiser. This function will only +actually modify the check chain if it finds I<*old_checker_p> to be null. +This function is also thread safe on the small scale. It uses appropriate +locking to avoid race conditions in accessing L. + +When this function is called, the function referenced by I +must be ready to be called, except for I<*old_checker_p> being unfilled. +In a threading situation, I may be called immediately, +even before this function has returned. I<*old_checker_p> will always +be appropriately set before I is called. If I +decides not to do anything special with an op that it is given (which +is the usual case for most uses of op check hooking), it must chain the +check function referenced by I<*old_checker_p>. + +If you want to influence compilation of calls to a specific subroutine, +then use L rather than hooking checking of all +C ops. + +=cut +*/ + +void +Perl_wrap_op_checker(pTHX_ Optype opcode, + Perl_check_t new_checker, Perl_check_t *old_checker_p) +{ + dVAR; + + PERL_ARGS_ASSERT_WRAP_OP_CHECKER; + if (*old_checker_p) return; + OP_CHECK_MUTEX_LOCK; + if (!*old_checker_p) { + *old_checker_p = PL_check[opcode]; + PL_check[opcode] = new_checker; + } + OP_CHECK_MUTEX_UNLOCK; +} + #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */ @@ -10698,8 +11268,8 @@ const_sv_xsub(pTHX_ CV* cv) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */