X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=befacc38c012cdbb1a35642ed1bcaf55907c9f57;hb=3ab4a224eb8d34c041977288575d251ee18f009f;hp=d2c68354b75cb739fcba01f915be80714f754257;hpb=11206fddaf7ef0686e22e60221d236872f9d4063;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index d2c6835..befacc3 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -104,12 +104,17 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #if defined(PL_OP_SLAB_ALLOC) +#ifdef PERL_DEBUG_READONLY_OPS +# define PERL_SLAB_SIZE 4096 +# include +#endif + #ifndef PERL_SLAB_SIZE #define PERL_SLAB_SIZE 2048 #endif void * -Perl_Slab_Alloc(pTHX_ int m, size_t sz) +Perl_Slab_Alloc(pTHX_ size_t sz) { /* * To make incrementing use count easy PL_OpSlab is an I32 * @@ -119,11 +124,26 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) */ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); if ((PL_OpSpace -= sz) < 0) { - PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); +#ifdef PERL_DEBUG_READONLY_OPS + /* We need to allocate chunk by chunk so that we can control the VM + mapping */ + PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0); + + DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", + (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), + PL_OpPtr)); + if(PL_OpPtr == MAP_FAILED) { + perror("mmap failed"); + abort(); + } +#else + + PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*)); +#endif if (!PL_OpPtr) { return NULL; } - Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); /* We reserve the 0'th I32 sized chunk as a use count */ PL_OpSlab = (I32 *) PL_OpPtr; /* Reduce size by the use count word, and by the size we need. @@ -135,6 +155,14 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) means that at run time access is cache friendly upward */ PL_OpPtr += PERL_SLAB_SIZE; + +#ifdef PERL_DEBUG_READONLY_OPS + /* We remember this slab. */ + /* This implementation isn't efficient, but it is simple. */ + PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1)); + PL_slabs[PL_slab_count++] = PL_OpSlab; + DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab)); +#endif } assert( PL_OpSpace >= 0 ); /* Move the allocation pointer down */ @@ -147,6 +175,70 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz) return (void *)(PL_OpPtr + 1); } +#ifdef PERL_DEBUG_READONLY_OPS +void +Perl_pending_Slabs_to_ro(pTHX) { + /* Turn all the allocated op slabs read only. */ + U32 count = PL_slab_count; + I32 **const slabs = PL_slabs; + + /* Reset the array of pending OP slabs, as we're about to turn this lot + read only. Also, do it ahead of the loop in case the warn triggers, + and a warn handler has an eval */ + + PL_slabs = NULL; + PL_slab_count = 0; + + /* Force a new slab for any further allocation. */ + PL_OpSpace = 0; + + while (count--) { + void *const start = slabs[count]; + const size_t size = PERL_SLAB_SIZE* sizeof(I32*); + if(mprotect(start, size, PROT_READ)) { + Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", + start, (unsigned long) size, errno); + } + } + + free(slabs); +} + +STATIC void +S_Slab_to_rw(pTHX_ void *op) +{ + I32 * const * const ptr = (I32 **) op; + I32 * const slab = ptr[-1]; + assert( ptr-1 > (I32 **) slab ); + assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); + assert( *slab > 0 ); + if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) { + Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", + slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno); + } +} + +OP * +Perl_op_refcnt_inc(pTHX_ OP *o) +{ + if(o) { + Slab_to_rw(o); + ++o->op_targ; + } + return o; + +} + +PADOFFSET +Perl_op_refcnt_dec(pTHX_ OP *o) +{ + Slab_to_rw(o); + return --o->op_targ; +} +#else +# define Slab_to_rw(op) +#endif + void Perl_Slab_Free(pTHX_ void *op) { @@ -155,12 +247,38 @@ Perl_Slab_Free(pTHX_ void *op) assert( ptr-1 > (I32 **) slab ); assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); assert( *slab > 0 ); + Slab_to_rw(op); if (--(*slab) == 0) { # ifdef NETWARE # define PerlMemShared PerlMem # endif +#ifdef PERL_DEBUG_READONLY_OPS + U32 count = PL_slab_count; + /* Need to remove this slab from our list of slabs */ + if (count) { + while (count--) { + if (PL_slabs[count] == slab) { + /* Found it. Move the entry at the end to overwrite it. */ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "Deallocate %p by moving %p from %lu to %lu\n", + PL_OpSlab, + PL_slabs[PL_slab_count - 1], + PL_slab_count, count)); + PL_slabs[count] = PL_slabs[--PL_slab_count]; + /* Could realloc smaller at this point, but probably not + worth it. */ + if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) { + perror("munmap failed"); + abort(); + } + break; + } + } + } +#else PerlMemShared_free(slab); +#endif if (slab == PL_OpSlab) { PL_OpSpace = 0; } @@ -224,7 +342,7 @@ S_no_bareword_allowed(pTHX_ const OP *o) return; /* various ok barewords are hidden in extra OP_NULL */ qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", - (void*)cSVOPo_sv)); + SVfARG(cSVOPo_sv))); } /* "register" allocation */ @@ -277,6 +395,25 @@ Perl_allocmy(pTHX_ const char *const name) return off; } +/* free the body of an op without examining its contents. + * Always use this rather than FreeOp directly */ + +static void +S_op_destroy(pTHX_ OP *o) +{ + if (o->op_latefree) { + o->op_latefreed = 1; + return; + } + FreeOp(o); +} + +#ifdef USE_ITHREADS +# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b) +#else +# define forget_pmop(a,b) S_forget_pmop(aTHX_ a) +#endif + /* Destructor */ void @@ -287,6 +424,11 @@ Perl_op_free(pTHX_ OP *o) if (!o || o->op_static) return; + if (o->op_latefreed) { + if (o->op_latefree) + return; + goto do_free; + } type = o->op_type; if (o->op_private & OPpREFCOUNTED) { @@ -302,9 +444,13 @@ Perl_op_free(pTHX_ OP *o) OP_REFCNT_LOCK; refcnt = OpREFCNT_dec(o); OP_REFCNT_UNLOCK; - if (refcnt) + if (refcnt) { + /* Need to find and remove any pattern match ops from the list + we maintain for reset(). */ + find_and_forget_pmops(o); return; } + } break; default: break; @@ -321,12 +467,22 @@ Perl_op_free(pTHX_ OP *o) if (type == OP_NULL) type = (OPCODE)o->op_targ; +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_rw(o); +#endif + /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ - if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) + if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) { cop_free((COP*)o); + } op_clear(o); + if (o->op_latefree) { + o->op_latefreed = 1; + return; + } + do_free: FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) @@ -414,54 +570,40 @@ Perl_op_clear(pTHX_ OP *o) /* FALL THROUGH */ case OP_TRANS: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { +#ifdef USE_ITHREADS + if (cPADOPo->op_padix > 0) { + pad_swipe(cPADOPo->op_padix, TRUE); + cPADOPo->op_padix = 0; + } +#else SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; +#endif } else { - Safefree(cPVOPo->op_pv); + PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; } break; case OP_SUBST: - op_free(cPMOPo->op_pmreplroot); + op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS - if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { + if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { /* No GvIN_PAD_off here, because other references may still * exist on the pad */ - pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); + pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else - SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); + SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: - { - HV * const pmstash = PmopSTASH(cPMOPo); - if (pmstash && !SvIS_FREED(pmstash)) { - MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); - if (mg) { - PMOP *pmop = (PMOP*) mg->mg_obj; - PMOP *lastpmop = NULL; - while (pmop) { - if (cPMOPo == pmop) { - if (lastpmop) - lastpmop->op_pmnext = pmop->op_pmnext; - else - mg->mg_obj = (SV*) pmop->op_pmnext; - break; - } - lastpmop = pmop; - pmop = pmop->op_pmnext; - } - } - } - PmopSTASH_free(cPMOPo); - } - cPMOPo->op_pmreplroot = NULL; + forget_pmop(cPMOPo, 1); + cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; /* we use the "SAFE" version of the PM_ macros here * since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared @@ -473,6 +615,7 @@ clear_pmop: #ifdef USE_ITHREADS if(PL_regex_pad) { /* We could be in destruction */ av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); + SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]); SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); } @@ -490,7 +633,7 @@ clear_pmop: STATIC void S_cop_free(pTHX_ COP* cop) { - Safefree(cop->cop_label); /* FIXME: treaddead ??? */ + CopLABEL_free(cop); CopFILE_free(cop); CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) @@ -498,6 +641,65 @@ S_cop_free(pTHX_ COP* cop) Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash); } +STATIC void +S_forget_pmop(pTHX_ PMOP *const o +#ifdef USE_ITHREADS + , U32 flags +#endif + ) +{ + HV * const pmstash = PmopSTASH(o); + if (pmstash && !SvIS_FREED(pmstash)) { + MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); + if (mg) { + PMOP **const array = (PMOP**) mg->mg_ptr; + U32 count = mg->mg_len / sizeof(PMOP**); + U32 i = count; + + while (i--) { + if (array[i] == o) { + /* Found it. Move the entry at the end to overwrite it. */ + array[i] = array[--count]; + mg->mg_len = count * sizeof(PMOP**); + /* Could realloc smaller at this point always, but probably + not worth it. Probably worth free()ing if we're the + last. */ + if(!count) { + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + } + break; + } + } + } + } + if (PL_curpm == o) + PL_curpm = NULL; +#ifdef USE_ITHREADS + if (flags) + PmopSTASH_free(o); +#endif +} + +STATIC void +S_find_and_forget_pmops(pTHX_ OP *o) +{ + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; + while (kid) { + switch (kid->op_type) { + case OP_SUBST: + case OP_PUSHRE: + case OP_MATCH: + case OP_QR: + forget_pmop((PMOP*)kid, 0); + } + find_and_forget_pmops(kid); + kid = kid->op_sibling; + } + } +} + void Perl_op_null(pTHX_ OP *o) { @@ -616,7 +818,7 @@ Perl_scalar(pTHX_ OP *o) break; case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) + if (!kPMOP->op_pmreplrootu.op_pmreplroot) deprecate_old("implicit split to @_"); } /* FALL THROUGH */ @@ -911,7 +1113,7 @@ Perl_scalarvoid(pTHX_ OP *o) return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) + if (!kPMOP->op_pmreplrootu.op_pmreplroot) deprecate_old("implicit split to @_"); } break; @@ -1527,10 +1729,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) } break; - case OP_THREADSV: - o->op_flags |= OPf_MOD; /* XXX ??? */ - break; - case OP_RV2AV: case OP_RV2HV: if (set_op_ref) @@ -1619,7 +1817,7 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ - SAVEINT(PL_expect); + SAVEI8(PL_expect); stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" @@ -1769,7 +1967,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ - yyerror(Perl_form(aTHX_ "Can't declare %s in %s", + yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", OP_DESC(o), PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")); } else if (attrs) { @@ -1876,7 +2074,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { const char * const desc = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS) - ? rtype : OP_MATCH]; + ? (int)rtype : OP_MATCH]; const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) ? "@array" : "%hash"); Perl_warner(aTHX_ packWARN(WARN_MISC), @@ -2022,7 +2220,7 @@ Perl_newPROG(pTHX_ OP *o) if (o->op_type == OP_STUB) { PL_comppad_name = 0; PL_compcv = 0; - FreeOp(o); + S_op_destroy(aTHX_ o); return; } PL_main_root = scope(sawparens(scalarvoid(o))); @@ -2036,7 +2234,8 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV * const cv = get_cv("DB::postponed", FALSE); + CV * const cv + = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0); if (cv) { dSP; PUSHMARK(SP); @@ -2118,8 +2317,8 @@ Perl_fold_constants(pTHX_ register OP *o) dVAR; register OP *curop; OP *newop; - I32 type = o->op_type; - SV *sv = NULL; + VOL I32 type = o->op_type; + SV * VOL sv = NULL; int ret = 0; I32 oldscope; OP *old_next; @@ -2233,7 +2432,7 @@ Perl_fold_constants(pTHX_ register OP *o) if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, (GV*)sv); else - newop = newSVOP(OP_CONST, 0, sv); + newop = newSVOP(OP_CONST, 0, (SV*)sv); op_getmad(o,newop,'f'); return newop; @@ -2258,6 +2457,8 @@ Perl_gen_constant_list(pTHX_ register OP *o) pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); pp_anonlist(); PL_tmps_floor = oldtmps_floor; @@ -2362,7 +2563,7 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) last->op_madprop = 0; #endif - FreeOp(last); + S_op_destroy(aTHX_ (OP*)last); return (OP*)first; } @@ -2698,6 +2899,9 @@ Perl_newOP(pTHX_ I32 type, I32 flags) o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; o->op_flags = (U8)flags; + o->op_latefree = 0; + o->op_latefreed = 0; + o->op_attached = 0; o->op_next = o; o->op_private = (U8)(0 | (flags >> 8)); @@ -2786,7 +2990,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; - SV * const rstr = ((SVOP*)repl)->op_sv; + SV * const rstr = +#ifdef PERL_MAD + (repl->op_type == OP_NULL) + ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : +#endif + ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; const U8 *t = (U8*)SvPV_const(tstr, tlen); @@ -2799,6 +3008,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; const I32 squash = o->op_private & OPpTRANS_SQUASH; I32 del = o->op_private & OPpTRANS_DELETE; + SV* swash; PL_hints |= HINT_BLOCK_SCOPE; if (SvUTF8(tstr)) @@ -2992,13 +3202,23 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; - Safefree(cPVOPo->op_pv); - cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); + PerlMemShared_free(cPVOPo->op_pv); + cPVOPo->op_pv = NULL; + + swash = (SV*)swash_init("utf8", "", listsv, bits, none); +#ifdef USE_ITHREADS + cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); + SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); + PAD_SETSV(cPADOPo->op_padix, swash); + SvPADTMP_on(swash); +#else + cSVOPo->op_sv = swash; +#endif SvREFCNT_dec(listsv); SvREFCNT_dec(transv); if (!del && havefinal && rlen) - (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, + (void)hv_store((HV*)SvRV(swash), "FINAL", 5, newSVuv((UV)final), 0); if (grows) @@ -3047,8 +3267,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } else if (j >= (I32)rlen) j = rlen - 1; - else - cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); + else { + tbl = + (short *) + PerlMemShared_realloc(tbl, + (0x101+rlen-j) * sizeof(short)); + cPVOPo->op_pv = (char*)tbl; + } tbl[0x100] = (short)(rlen - j); for (i=0; i < (I32)rlen - j; i++) tbl[0x101+i] = r[j+i]; @@ -3107,10 +3332,10 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_private = (U8)(0 | (flags >> 8)); if (PL_hints & HINT_RE_TAINT) - pmop->op_pmpermflags |= PMf_RETAINT; + pmop->op_pmflags |= PMf_RETAINT; if (PL_hints & HINT_LOCALE) - pmop->op_pmpermflags |= PMf_LOCALE; - pmop->op_pmflags = pmop->op_pmpermflags; + pmop->op_pmflags |= PMf_LOCALE; + #ifdef USE_ITHREADS if (av_len((AV*) PL_regex_pad[0]) > -1) { @@ -3126,18 +3351,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) } #endif - /* link into pm list */ - if (type != OP_TRANS && PL_curstash) { - MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab); - - if (!mg) { - mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0); - } - pmop->op_pmnext = (PMOP*)mg->mg_obj; - mg->mg_obj = (SV*)pmop; - PmopSTASH_set(pmop,PL_curstash); - } - return CHECKOP(type, pmop); } @@ -3200,7 +3413,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) STRLEN plen; SV * const pat = ((SVOP*)expr)->op_sv; const char *p = SvPV_const(pat, plen); - if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { + U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; + if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) { U32 was_readonly = SvREADONLY(pat); if (was_readonly) { @@ -3218,14 +3432,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) SvFLAGS(pat) |= was_readonly; p = SvPV_const(pat, plen); - pm->op_pmflags |= PMf_SKIPWHITE; + pm_flags |= RXf_SKIPWHITE; } if (DO_UTF8(pat)) - pm->op_pmdynflags |= PMdf_UTF8; - /* FIXME - can we make this function take const char * args? */ - PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm)); - if (strEQ("\\s+", PM_GETRE(pm)->precomp)) - pm->op_pmflags |= PMf_WHITE; + pm_flags |= RXf_UTF8; + PM_SETRE(pm, CALLREGCOMP(pat, pm_flags)); + #ifdef PERL_MAD op_getmad(expr,(OP*)pm,'e'); #else @@ -3279,7 +3491,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) else { OP *lastop = NULL; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { - if (PL_opargs[curop->op_type] & OA_DANGEROUS) { + if (curop->op_type == OP_SCOPE + || curop->op_type == OP_LEAVE + || (PL_opargs[curop->op_type] & OA_DANGEROUS)) { if (curop->op_type == OP_GV) { GV * const gv = cGVOPx_gv(curop); repl_has_vars = 1; @@ -3298,7 +3512,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) { + curop->op_type == OP_PADANY) + { repl_has_vars = 1; } else if (curop->op_type == OP_PUSHRE) @@ -3312,15 +3527,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) - || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { + || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) + { pm->op_pmflags |= PMf_CONST; /* const for long enough */ - pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ prepend_elem(o->op_type, scalar(repl), o); } else { if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ pm->op_pmflags |= PMf_MAYBE_CONST; - pm->op_pmpermflags |= PMf_MAYBE_CONST; } NewOp(1101, rcop, 1, LOGOP); rcop->op_type = OP_SUBSTCONT; @@ -3334,8 +3548,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) rcop->op_next = LINKLIST(repl); repl->op_next = (OP*)rcop; - pm->op_pmreplroot = scalar((OP*)rcop); - pm->op_pmreplstart = LINKLIST(rcop); + pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); + assert(!(pm->op_pmflags & PMf_ONCE)); + pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); rcop->op_next = 0; } } @@ -3361,6 +3576,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) return CHECKOP(type, svop); } +#ifdef USE_ITHREADS OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { @@ -3372,8 +3588,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_padix = pad_alloc(type, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); - if (sv) - SvPADTMP_on(sv); + assert(sv); + SvPADTMP_on(sv); padop->op_next = (OP*)padop; padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) @@ -3382,17 +3598,18 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, padop); } +#endif OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { dVAR; + assert(gv); #ifdef USE_ITHREADS - if (gv) - GvIN_PAD_on(gv); - return newPADOP(type, flags, SvREFCNT_inc_simple(gv)); + GvIN_PAD_on(gv); + return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else - return newSVOP(type, flags, SvREFCNT_inc_simple(gv)); + return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #endif } @@ -3422,8 +3639,7 @@ void Perl_package(pTHX_ OP *o) { dVAR; - const char *name; - STRLEN len; + SV *const sv = cSVOPo->op_sv; #ifdef PERL_MAD OP *pegop; #endif @@ -3431,9 +3647,13 @@ Perl_package(pTHX_ OP *o) save_hptr(&PL_curstash); save_item(PL_curstname); - name = SvPV_const(cSVOPo->op_sv, len); - PL_curstash = gv_stashpvn(name, len, TRUE); - sv_setpvn(PL_curstname, name, len); + PL_curstash = gv_stashsv(sv, GV_ADD); + + /* In case mg.c:Perl_magic_setisa faked + this package earlier, we clear the fake flag */ + HvMROMETA(PL_curstash)->fake = 0; + + sv_setsv(PL_curstname, sv); PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; @@ -3643,7 +3863,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; - const int oexpect = PL_expect; + const U8 oexpect = PL_expect; utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); @@ -3780,10 +4000,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) * that value, we know we've got commonality. We could use a * single bit marker, but then we'd have to make 2 passes, first * to clear the flag, then to test and set it. To find somewhere - * to store these values, evil chicanery is done with SvCUR(). + * to store these values, evil chicanery is done with SvUVX(). */ - if (!(left->op_private & OPpLVAL_INTRO)) { + { OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { @@ -3816,19 +4036,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) break; } else if (curop->op_type == OP_PUSHRE) { - if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS - GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, - ((PMOP*)curop)->op_pmreplroot)); -#else - GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; -#endif + if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { + GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; GvASSIGN_GENERATION_set(gv, PL_generation); + } +#else + GV *const gv + = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; + if (gv) { + if (gv == PL_defgv + || (int)GvASSIGN_GENERATION(gv) == PL_generation) + break; GvASSIGN_GENERATION_set(gv, PL_generation); } +#endif } else break; @@ -3838,6 +4063,45 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (curop != o) o->op_private |= OPpASSIGN_COMMON; } + + if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC)) + && (left->op_type == OP_LIST + || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) + { + OP* lop = ((LISTOP*)left)->op_first; + while (lop) { + if (lop->op_type == OP_PADSV || + lop->op_type == OP_PADAV || + lop->op_type == OP_PADHV || + lop->op_type == OP_PADANY) + { + if (lop->op_private & OPpPAD_STATE) { + if (left->op_private & OPpLVAL_INTRO) { + o->op_private |= OPpASSIGN_STATE; + /* hijacking PADSTALE for uninitialized state variables */ + SvPADSTALE_on(PAD_SVl(lop->op_targ)); + } + else { /* we already checked for WARN_MISC before */ + Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized", + PAD_COMPNAME_PV(lop->op_targ)); + } + } + } + lop = lop->op_sibling; + } + } + else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE)) + == (OPpLVAL_INTRO | OPpPAD_STATE)) + && ( left->op_type == OP_PADSV + || left->op_type == OP_PADAV + || left->op_type == OP_PADHV + || left->op_type == OP_PADANY)) + { + o->op_private |= OPpASSIGN_STATE; + /* hijacking PADSTALE for uninitialized state variables */ + SvPADSTALE_on(PAD_SVl(left->op_targ)); + } + if (right && right->op_type == OP_SPLIT) { OP* tmpop = ((LISTOP*)right)->op_first; if (tmpop && (tmpop->op_type == OP_PUSHRE)) { @@ -3847,12 +4111,20 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) !(o->op_private & OPpASSIGN_COMMON) ) { tmpop = ((UNOP*)left)->op_first; - if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { + if (tmpop->op_type == OP_GV +#ifdef USE_ITHREADS + && !pm->op_pmreplrootu.op_pmtargetoff +#else + && !pm->op_pmreplrootu.op_pmtargetgv +#endif + ) { #ifdef USE_ITHREADS - pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); + pm->op_pmreplrootu.op_pmtargetoff + = cPADOPx(tmpop)->op_padix; cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else - pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; + pm->op_pmreplrootu.op_pmtargetgv + = (GV*)cSVOPx(tmpop)->op_sv; cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif pm->op_pmflags |= PMf_ONCE; @@ -3930,7 +4202,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_next = (OP*)cop; if (label) { - cop->cop_label = label; + CopLABEL_set(cop, label); PL_hints |= HINT_BLOCK_SCOPE; } cop->cop_seq = seq; @@ -3959,10 +4231,13 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) CopSTASH_set(cop, PL_curstash); if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE); - if (svp && *svp != &PL_sv_undef ) { - (void)SvIOK_on(*svp); - SvIV_set(*svp, PTR2IV(cop)); + AV *av = CopFILEAVx(PL_curcop); + if (av) { + SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); + if (svp && *svp != &PL_sv_undef ) { + (void)SvIOK_on(*svp); + SvIV_set(*svp, PTR2IV(cop)); + } } } @@ -4145,38 +4420,24 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) scalarboolean(first); if (first->op_type == OP_CONST) { + /* Left or right arm of the conditional? */ + const bool left = SvTRUE(((SVOP*)first)->op_sv); + OP *live = left ? trueop : falseop; + OP *const dead = left ? falseop : trueop; if (first->op_private & OPpCONST_BARE && first->op_private & OPpCONST_STRICT) { no_bareword_allowed(first); } - if (SvTRUE(((SVOP*)first)->op_sv)) { -#ifdef PERL_MAD - if (PL_madskills) { - trueop = newUNOP(OP_NULL, 0, trueop); - op_getmad(first,trueop,'C'); - op_getmad(falseop,trueop,'e'); - } - /* FIXME for MAD - should there be an ELSE here? */ -#else - op_free(first); - op_free(falseop); -#endif - return trueop; - } - else { -#ifdef PERL_MAD - if (PL_madskills) { - falseop = newUNOP(OP_NULL, 0, falseop); - op_getmad(first,falseop,'C'); - op_getmad(trueop,falseop,'t'); - } - /* FIXME for MAD - should there be an ELSE here? */ -#else + if (PL_madskills) { + /* This is all dead code when PERL_MAD is not defined. */ + live = newUNOP(OP_NULL, 0, live); + op_getmad(first, live, 'C'); + op_getmad(dead, live, left ? 'e' : 't'); + } else { op_free(first); - op_free(trueop); -#endif - return falseop; + op_free(dead); } + return live; } NewOp(1101, logop, 1, LOGOP); logop->op_type = OP_COND_EXPR; @@ -4430,7 +4691,15 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ sv->op_type = OP_RV2GV; sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; - if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) + + /* The op_type check is needed to prevent a possible segfault + * if the loop variable is undeclared and 'strict vars' is in + * effect. This is illegal but is nonetheless parsed, so we + * may reach this point with an OP_CONST where we're expecting + * an OP_GV. + */ + if (cUNOPx(sv)->op_first->op_type == OP_GV + && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) iterpflags |= OPpITER_DEF; } else if (sv->op_type == OP_PADSV) { /* private variable */ @@ -4444,21 +4713,16 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP } sv = NULL; } - else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ - padoff = sv->op_targ; - if (PL_madskills) - madsv = sv; - else { - sv->op_targ = 0; - iterflags |= OPf_SPECIAL; - op_free(sv); - } - sv = NULL; - } else Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); - if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_")) - iterpflags |= OPpITER_DEF; + if (padoff) { + SV *const namesv = PAD_COMPNAME_SV(padoff); + STRLEN len; + const char *const name = SvPV_const(namesv, len); + + if (len == 2 && name[0] == '$' && name[1] == '_') + iterpflags |= OPpITER_DEF; + } } else { const PADOFFSET offset = pad_findmy("$_"); @@ -4521,11 +4785,11 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LISTOP); - FreeOp(loop); + S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } #else - loop = PerlMemShared_realloc(loop, sizeof(LOOP)); + loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); #endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0); @@ -4546,8 +4810,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) o = newOP(type, OPf_SPECIAL); else { - o = newPVOP(type, 0, savepv(label->op_type == OP_CONST - ? SvPVx_nolen_const(((SVOP*)label)->op_sv) + o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST + ? SvPV_nolen_const(((SVOP*)label)->op_sv) : "")); } #ifdef PERL_MAD @@ -4596,8 +4860,7 @@ S_ref_array_or_hash(pTHX_ OP *cond) op_other if the match fails.) */ -STATIC -OP * +STATIC OP * S_newGIVWHENOP(pTHX_ OP *cond, OP *block, I32 enter_opcode, I32 leave_opcode, PADOFFSET entertarg) @@ -4651,8 +4914,7 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, [*] possibly surprising */ -STATIC -bool +STATIC bool S_looks_like_bool(pTHX_ const OP *o) { dVAR; @@ -4761,7 +5023,7 @@ Perl_cv_undef(pTHX_ CV *cv) /* for XSUBs CvFILE point directly to static memory; __FILE__ */ Safefree(CvFILE(cv)); } - CvFILE(cv) = 0; + CvFILE(cv) = NULL; #endif if (!CvISXSUB(cv) && CvROOT(cv)) { @@ -4813,11 +5075,11 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, if (gv) gv_efullname3(name = sv_newmortal(), gv, NULL); - sv_setpv(msg, "Prototype mismatch:"); + sv_setpvs(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name); + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv)); else sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); @@ -4825,7 +5087,7 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p); else sv_catpvs(msg, "none"); - Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); } } @@ -4986,11 +5248,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; - const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL; + const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; if (proto) { assert(proto->op_type == OP_CONST); - ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); } else ps = NULL; @@ -5033,9 +5295,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) sv_setpvn((SV*)gv, ps, ps_len); else sv_setiv((SV*)gv, -1); + SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; - PL_sub_generation++; goto done; } @@ -5129,7 +5391,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GvCV(gv) = NULL; cv = newCONSTSUB(NULL, name, const_sv); } - PL_sub_generation++; + mro_method_changed_in( /* sub Foo::Bar () { 123 } */ + (CvGV(cv) && GvSTASH(CvGV(cv))) + ? GvSTASH(CvGV(cv)) + : CvSTASH(cv) + ? CvSTASH(cv) + : PL_curstash + ); if (PL_madskills) goto install_block; op_free(block); @@ -5212,7 +5480,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } GvCVGEN(gv) = 0; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ } } CvGV(cv) = gv; @@ -5236,7 +5504,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); - Perl_croak(aTHX_ "%"SVf, (void*)ERRSV); + Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); } } } @@ -5248,6 +5516,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); + block->op_attached = 1; } else { /* This makes sub {}; work as expected. */ @@ -5260,6 +5529,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) #endif block = newblock; } + else + block->op_attached = 1; CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } CvROOT(cv)->op_private |= OPpREFCOUNTED; @@ -5279,9 +5550,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (name || aname) { - const char *s; - const char * const tname = (name ? name : aname); - if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV * const sv = newSV(0); SV * const tmpstr = sv_newmortal(); @@ -5307,24 +5575,32 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } - if ((s = strrchr(tname,':'))) - s++; - else - s = tname; + if (name && !PL_error_count) + process_special_blocks(name, gv, cv); + } - if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') - goto done; + done: + PL_copline = NOLINE; + LEAVE_SCOPE(floor); + return cv; +} - if (strEQ(s, "BEGIN") && !PL_error_count) { +STATIC void +S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, + CV *const cv) +{ + const char *const colon = strrchr(fullname,':'); + const char *const name = colon ? colon + 1 : fullname; + + if (*name == 'B') { + if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - if (!PL_beginav) - PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); @@ -5332,42 +5608,47 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CopHINTS_set(&PL_compiling, PL_hints); LEAVE; } - else if (strEQ(s, "END") && !PL_error_count) { - if (!PL_endav) - PL_endav = newAV(); - DEBUG_x( dump_sub(gv) ); - av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "CHECK") && !PL_error_count) { - if (!PL_checkav) - PL_checkav = newAV(); - DEBUG_x( dump_sub(gv) ); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); - av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "INIT") && !PL_error_count) { - if (!PL_initav) - PL_initav = newAV(); - DEBUG_x( dump_sub(gv) ); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); - av_push(PL_initav, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } + else + return; + } else { + if (*name == 'E') { + if strEQ(name, "END") { + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv); + } else + return; + } else if (*name == 'U') { + if (strEQ(name, "UNITCHECK")) { + /* It's never too late to run a unitcheck block */ + Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv); + } + else + return; + } else if (*name == 'C') { + if (strEQ(name, "CHECK")) { + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv); + } + else + return; + } else if (*name == 'I') { + if (strEQ(name, "INIT")) { + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); + Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv); + } + else + return; + } else + return; + DEBUG_x( dump_sub(gv) ); + GvCV(gv) = 0; /* cv has been hijacked */ } - - done: - PL_copline = NOLINE; - LEAVE_SCOPE(floor); - return cv; } -/* XXX unsafe for threads if eval_owner isn't held */ /* =for apidoc newCONSTSUB @@ -5414,6 +5695,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); + Safefree(file); #ifdef USE_ITHREADS if (stash) @@ -5526,12 +5808,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { - cv = (CV*)newSV(0); - sv_upgrade((SV *)cv, SVt_PVCV); + cv = (CV*)newSV_type(SVt_PVCV); if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* newXS */ } } CvGV(cv) = gv; @@ -5541,51 +5822,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) CvISXSUB_on(cv); CvXSUB(cv) = subaddr; - if (name) { - const char *s = strrchr(name,':'); - if (s) - s++; - else - s = name; - - if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') - goto done; - - if (strEQ(s, "BEGIN")) { - if (!PL_beginav) - PL_beginav = newAV(); - av_push(PL_beginav, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "END")) { - if (!PL_endav) - PL_endav = newAV(); - av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "CHECK")) { - if (!PL_checkav) - PL_checkav = newAV(); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); - av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "INIT")) { - if (!PL_initav) - PL_initav = newAV(); - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); - av_push(PL_initav, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - } + if (name) + process_special_blocks(name, gv, cv); else CvANON_on(cv); -done: return cv; } @@ -5619,7 +5860,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), o ? "Format %"SVf" redefined" - : "Format STDOUT redefined", (void*)cSVOPo->op_sv); + : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv)); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -5653,15 +5894,13 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) OP * Perl_newANONLIST(pTHX_ OP *o) { - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN)); + return convert(OP_ANONLIST, OPf_SPECIAL, o); } OP * Perl_newANONHASH(pTHX_ OP *o) { - return newUNOP(OP_REFGEN, 0, - mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN)); + return convert(OP_ANONHASH, OPf_SPECIAL, o); } OP * @@ -5785,10 +6024,6 @@ Perl_newSVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADSV]; return o; } - else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { - o->op_flags |= OPpDONE_SVREF; - return o; - } return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -5990,8 +6225,11 @@ Perl_ck_eval(pTHX_ OP *o) } o->op_targ = (PADOFFSET)PL_hints; if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { - /* Store a copy of %^H that pp_entereval can pick up */ - OP *hhop = newSVOP(OP_CONST, 0, + /* Store a copy of %^H that pp_entereval can pick up. + OPf_SPECIAL flags the opcode as being for this purpose, + so that it in turn will return a copy at every + eval.*/ + OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL, (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; @@ -6126,7 +6364,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) if (badthing) Perl_croak(aTHX_ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", - (void*)kidsv, badthing); + SVfARG(kidsv), badthing); } /* * This is a little tricky. We only want to add the symbol if we @@ -6284,7 +6522,7 @@ Perl_ck_fun(pTHX_ OP *o) if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", - (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6307,7 +6545,7 @@ Perl_ck_fun(pTHX_ OP *o) if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", - (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6370,13 +6608,9 @@ Perl_ck_fun(pTHX_ OP *o) */ priv = OPpDEREF; if (kid->op_type == OP_PADSV) { - name = PAD_COMPNAME_PV(kid->op_targ); - /* SvCUR of a pad namesv can't be trusted - * (see PL_generation), so calc its length - * manually */ - if (name) - len = strlen(name); - + SV *const namesv + = PAD_COMPNAME_SV(kid->op_targ); + name = SvPV_const(namesv, len); } else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) @@ -6679,6 +6913,22 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ } OP * +Perl_ck_readline(pTHX_ OP *o) +{ + if (!(o->op_flags & OPf_KIDS)) { + OP * const newop + = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); +#ifdef PERL_MAD + op_getmad(o,newop,'O'); +#else + op_free(o); +#endif + return newop; + } + return o; +} + +OP * Perl_ck_rfun(pTHX_ OP *o) { const OPCODE type = o->op_type; @@ -6716,16 +6966,6 @@ Perl_ck_listiob(pTHX_ OP *o) } OP * -Perl_ck_say(pTHX_ OP *o) -{ - o = ck_listiob(o); - o->op_type = OP_PRINT; - cLISTOPo->op_last = cLISTOPo->op_last->op_sibling - = newSVOP(OP_CONST, 0, newSVpvs("\n")); - return o; -} - -OP * Perl_ck_smartmatch(pTHX_ OP *o) { dVAR; @@ -6872,8 +7112,18 @@ Perl_ck_open(pTHX_ OP *o) o->op_private |= OPpOPEN_OUT_CRLF; } } - if (o->op_type == OP_BACKTICK) + if (o->op_type == OP_BACKTICK) { + if (!(o->op_flags & OPf_KIDS)) { + OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); +#ifdef PERL_MAD + op_getmad(o,newop,'O'); +#else + op_free(o); +#endif + return newop; + } return o; + } { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ @@ -7252,9 +7502,10 @@ Perl_ck_join(pTHX_ OP *o) if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); const char *pmstr = re ? re->precomp : "STRING"; + const STRLEN len = re ? re->prelen : 6; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "/%s/ should probably be written as \"%s\"", - pmstr, pmstr); + "/%.*s/ should probably be written as \"%.*s\"", + (int)len, pmstr, (int)len, pmstr); } } return ck_fun(o); @@ -7275,7 +7526,7 @@ Perl_ck_subr(pTHX_ OP *o) int optional = 0; I32 arg = 0; I32 contextclass = 0; - char *e = NULL; + const char *e = NULL; bool delete_op = 0; o->op_private |= OPpENTERSUB_HASTARG; @@ -7298,13 +7549,20 @@ Perl_ck_subr(pTHX_ OP *o) proto_end = proto + len; } if (CvASSERTION(cv)) { - if (PL_hints & HINT_ASSERTING) { + U32 asserthints = 0; + HV *const hinthv = GvHV(PL_hintgv); + if (hinthv) { + SV **svp = hv_fetchs(hinthv, "assertions", FALSE); + if (svp && *svp) + asserthints = SvUV(*svp); + } + if (asserthints & HINT_ASSERTING) { if (PERLDB_ASSERTION && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; } else { delete_op = 1; - if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) { + if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) { Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS), "Impossible to activate assertion call"); } @@ -7327,6 +7585,10 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private |= OPpENTERSUB_DB; while (o2 != cvop) { OP* o3; + if (PL_madskills && o2->op_type == OP_STUB) { + o2 = o2->op_sibling; + continue; + } if (PL_madskills && o2->op_type == OP_NULL) o3 = ((UNOP*)o2)->op_first; else @@ -7340,6 +7602,10 @@ Perl_ck_subr(pTHX_ OP *o) optional = 1; proto++; continue; + case '_': + /* _ must be at the end */ + if (proto[1] && proto[1] != ';') + goto oops; case '$': proto++; arg++; @@ -7445,8 +7711,7 @@ Perl_ck_subr(pTHX_ OP *o) if (o3->op_type == OP_RV2SV || o3->op_type == OP_PADSV || o3->op_type == OP_HELEM || - o3->op_type == OP_AELEM || - o3->op_type == OP_THREADSV) + o3->op_type == OP_AELEM) goto wrapref; if (!contextclass) bad_type(arg, "scalar", gv_ename(namegv), o3); @@ -7490,7 +7755,7 @@ Perl_ck_subr(pTHX_ OP *o) default: oops: Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, - gv_ename(namegv), (void*)cv); + gv_ename(namegv), SVfARG(cv)); } } else @@ -7499,8 +7764,14 @@ Perl_ck_subr(pTHX_ OP *o) prev = o2; o2 = o2->op_sibling; } /* while */ + if (o2 == cvop && proto && *proto == '_') { + /* generate an access to $_ */ + o2 = newDEFSVOP(); + o2->op_sibling = prev->op_sibling; + prev->op_sibling = o2; /* instead of cvop */ + } if (proto && !optional && proto_end > proto && - (*proto != '@' && *proto != '%' && *proto != ';')) + (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) return too_few_arguments(o, gv_ename(namegv)); if(delete_op) { #ifdef PERL_MAD @@ -7602,13 +7873,15 @@ Perl_peep(pTHX_ register OP *o) for (; o; o = o->op_next) { if (o->op_opt) break; + /* By default, this op has now been optimised. A couple of cases below + clear this again. */ + o->op_opt = 1; PL_op = o; switch (o->op_type) { case OP_SETSTATE: case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ - o->op_opt = 1; break; case OP_CONST: @@ -7651,14 +7924,13 @@ Perl_peep(pTHX_ register OP *o) o->op_targ = ix; } #endif - o->op_opt = 1; break; case OP_CONCAT: if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { if (o->op_next->op_private & OPpTARGET_MY) { if (o->op_flags & OPf_STACKED) /* chained concats */ - goto ignore_optimization; + break; /* ignore_optimization */ else { /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ o->op_targ = o->op_next->op_targ; @@ -7668,12 +7940,9 @@ Perl_peep(pTHX_ register OP *o) } op_null(o->op_next); } - ignore_optimization: - o->op_opt = 1; break; case OP_STUB: if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - o->op_opt = 1; break; /* Scalar stub must produce undef. List stub is noop */ } goto nothin; @@ -7689,20 +7958,17 @@ Perl_peep(pTHX_ register OP *o) has already occurred. This doesn't fix the real problem, though (See 20010220.007). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ - if (oldop && o->op_next) { - oldop->op_next = o->op_next; - continue; - } - break; + o->op_opt = 0; + /* FALL THROUGH */ case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: - nothin: + nothin: if (oldop && o->op_next) { oldop->op_next = o->op_next; + o->op_opt = 0; continue; } - o->op_opt = 1; break; case OP_PADAV: @@ -7739,7 +8005,6 @@ Perl_peep(pTHX_ register OP *o) o->op_flags |= OPf_SPECIAL; o->op_type = OP_AELEMFAST; } - o->op_opt = 1; break; } @@ -7761,7 +8026,7 @@ Perl_peep(pTHX_ register OP *o) gv_efullname3(sv, gv, NULL); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf"() called too early to check prototype", - (void*)sv); + SVfARG(sv)); } } else if (o->op_next->op_type == OP_READLINE @@ -7776,7 +8041,6 @@ Perl_peep(pTHX_ register OP *o) op_null(o->op_next); } - o->op_opt = 1; break; case OP_MAPWHILE: @@ -7789,7 +8053,6 @@ Perl_peep(pTHX_ register OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: - o->op_opt = 1; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ @@ -7797,7 +8060,6 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: case OP_ENTERITER: - o->op_opt = 1; while (cLOOP->op_redoop->op_type == OP_NULL) cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); @@ -7809,18 +8071,16 @@ Perl_peep(pTHX_ register OP *o) peep(cLOOP->op_lastop); break; - case OP_QR: - case OP_MATCH: case OP_SUBST: - o->op_opt = 1; - while (cPMOP->op_pmreplstart && - cPMOP->op_pmreplstart->op_type == OP_NULL) - cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; - peep(cPMOP->op_pmreplstart); + assert(!(cPMOP->op_pmflags & PMf_ONCE)); + while (cPMOP->op_pmstashstartu.op_pmreplstart && + cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmstashstartu.op_pmreplstart + = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; + peep(cPMOP->op_pmstashstartu.op_pmreplstart); break; case OP_EXEC: - o->op_opt = 1; if (o->op_next && o->op_next->op_type == OP_NEXTSTATE && ckWARN(WARN_SYNTAX)) { @@ -7847,8 +8107,6 @@ Perl_peep(pTHX_ register OP *o) const char *key = NULL; STRLEN keylen; - o->op_opt = 1; - if (((BINOP*)o)->op_last->op_type != OP_CONST) break; @@ -7975,8 +8233,6 @@ Perl_peep(pTHX_ register OP *o) /* make @a = sort @a act in-place */ - o->op_opt = 1; - oright = cUNOPx(oright)->op_sibling; if (!oright) break; @@ -8067,7 +8323,6 @@ Perl_peep(pTHX_ register OP *o) OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; LISTOP *enter, *exlist; - o->op_opt = 1; enter = (LISTOP *) o->op_next; if (!enter) @@ -8158,13 +8413,6 @@ Perl_peep(pTHX_ register OP *o) UNOP *refgen, *rv2cv; LISTOP *exlist; - /* I do not understand this, but if o->op_opt isn't set to 1, - various tests in ext/B/t/bytecode.t fail with no readily - apparent cause. */ - - o->op_opt = 1; - - if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID) break; @@ -8205,8 +8453,11 @@ Perl_peep(pTHX_ register OP *o) } - default: - o->op_opt = 1; + case OP_QR: + case OP_MATCH: + if (!(cPMOP->op_pmflags & PMf_ONCE)) { + assert (!cPMOP->op_pmstashstartu.op_pmreplstart); + } break; } oldop = o;