X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=1535e4cd8f7c069b73e3a45016ee386cf1e8ded1;hb=c16639b530c8551bfbd92ceea654ab91dfea918a;hp=765f091979221025e745ac1398e3133d54f5ee90;hpb=5dd42e15760f2e77ab3979bfe1b6aafaa9ff1227;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 765f091..1535e4c 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,7 +1,7 @@ /* pp_hot.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 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. @@ -16,6 +16,19 @@ * Fire, Foes! Awake! */ +/* This file contains 'hot' pp ("push/pop") functions that + * execute the opcodes that make up a perl program. A typical pp function + * expects to find its arguments on the stack, and usually pushes its + * results onto the stack, hence the 'pp' terminology. Each OP structure + * contains a pointer to the relevant pp_foo() function. + * + * By 'hot', we mean common ops whose execution speed is critical. + * By gathering them together into a single file, we encourage + * CPU cache hits on hot code. Also it could be taken as a warning not to + * change any code in this file unless you're sure it won't affect + * performance. + */ + #include "EXTERN.h" #define PERL_IN_PP_HOT_C #include "perl.h" @@ -24,13 +37,22 @@ PP(pp_const) { + dVAR; dSP; - XPUSHs(cSVOP_sv); + if ( PL_op->op_flags & OPf_SPECIAL ) + /* This is a const op added to hold the hints hash for + pp_entereval. The hash can be modified by the code + being eval'ed, so we return a copy instead. */ + XPUSHs(sv_2mortal((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv))); + else + /* Normal const. */ + XPUSHs(cSVOP_sv); RETURN; } PP(pp_nextstate) { + dVAR; PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -40,35 +62,39 @@ PP(pp_nextstate) PP(pp_gvsv) { + dVAR; dSP; EXTEND(SP,1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSV(cGVOP_gv)); + PUSHs(GvSVn(cGVOP_gv)); RETURN; } PP(pp_null) { + dVAR; return NORMAL; } PP(pp_setstate) { + dVAR; PL_curcop = (COP*)PL_op; return NORMAL; } PP(pp_pushmark) { + dVAR; PUSHMARK(PL_stack_sp); return NORMAL; } PP(pp_stringify) { - dSP; dTARGET; + dVAR; dSP; dTARGET; sv_copypv(TARG,TOPs); SETTARG; RETURN; @@ -76,32 +102,85 @@ PP(pp_stringify) PP(pp_gv) { - dSP; + dVAR; dSP; XPUSHs((SV*)cGVOP_gv); RETURN; } PP(pp_and) { - dSP; + dVAR; dSP; if (!SvTRUE(TOPs)) RETURN; else { - --SP; + if (PL_op->op_type == OP_AND) + --SP; RETURNOP(cLOGOP->op_other); } } PP(pp_sassign) { - dSP; dPOPTOPssrl; + dVAR; dSP; dPOPTOPssrl; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { - SV *temp; - temp = left; left = right; right = temp; + SV * const temp = left; + left = right; right = temp; } if (PL_tainting && PL_tainted && !SvTAINTED(left)) TAINT_NOT; + if (PL_op->op_private & OPpASSIGN_CV_TO_GV) { + SV * const cv = SvRV(left); + const U32 cv_type = SvTYPE(cv); + const U32 gv_type = SvTYPE(right); + const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; + + if (!got_coderef) { + assert(SvROK(cv)); + } + + /* Can do the optimisation if right (LVALUE) is not a typeglob, + left (RVALUE) is a reference to something, and we're in void + context. */ + if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) { + /* Is the target symbol table currently empty? */ + GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV); + if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { + /* Good. Create a new proxy constant subroutine in the target. + The gv becomes a(nother) reference to the constant. */ + SV *const value = SvRV(cv); + + SvUPGRADE((SV *)gv, SVt_RV); + SvPCS_IMPORTED_on(gv); + SvRV_set(gv, value); + SvREFCNT_inc_simple_void(value); + SETs(right); + RETURN; + } + } + + /* Need to fix things up. */ + if (gv_type != SVt_PVGV) { + /* Need to fix GV. */ + right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV); + } + + if (!got_coderef) { + /* We've been returned a constant rather than a full subroutine, + but they expect a subroutine reference to apply. */ + ENTER; + SvREFCNT_inc_void(SvRV(cv)); + /* newCONSTSUB takes a reference count on the passed in SV + from us. We set the name to NULL, otherwise we get into + all sorts of fun as the reference to our new sub is + donated to the GV that we're about to assign to. + */ + SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL, + SvRV(cv))); + SvREFCNT_dec(cv); + LEAVE; + } + } SvSetMagicSV(right, left); SETs(right); RETURN; @@ -109,7 +188,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - dSP; + dVAR; dSP; if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); else @@ -118,6 +197,7 @@ PP(pp_cond_expr) PP(pp_unstack) { + dVAR; I32 oldsave; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -129,25 +209,28 @@ PP(pp_unstack) PP(pp_concat) { - dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - STRLEN llen; - char* lpv; bool lbyte; STRLEN rlen; - char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */ - bool rbyte = !SvUTF8(right), rcopied = FALSE; + const char *rpv = NULL; + bool rbyte = FALSE; + bool rcopied = FALSE; if (TARG == right && right != left) { + /* mg_get(right) may happen here ... */ + rpv = SvPV_const(right, rlen); + rbyte = !DO_UTF8(right); right = sv_2mortal(newSVpvn(rpv, rlen)); - rpv = SvPV(right, rlen); /* no point setting UTF8 here */ + rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ rcopied = TRUE; } if (TARG != left) { - lpv = SvPV(left, llen); /* mg_get(left) may happen here */ - lbyte = !SvUTF8(left); + STRLEN llen; + const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */ + lbyte = !DO_UTF8(left); sv_setpvn(TARG, lpv, llen); if (!lbyte) SvUTF8_on(TARG); @@ -155,25 +238,24 @@ PP(pp_concat) SvUTF8_off(TARG); } else { /* TARG == left */ - if (SvGMAGICAL(left)) - mg_get(left); /* or mg_get(left) may happen here */ - if (!SvOK(TARG)) - sv_setpv(left, ""); - lpv = SvPV_nomg(left, llen); - lbyte = !SvUTF8(left); - } - -#if defined(PERL_Y2KWARN) - if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) { - if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9' - && (llen == 2 || !isDIGIT(lpv[llen - 3]))) - { - Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s", - "about to append an integer to '19'"); - } + STRLEN llen; + SvGETMAGIC(left); /* or mg_get(left) may happen here */ + if (!SvOK(TARG)) { + if (left == right && ckWARN(WARN_UNINITIALIZED)) + report_uninit(right); + sv_setpvn(left, "", 0); + } + (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */ + lbyte = !DO_UTF8(left); + if (IN_BYTES) + SvUTF8_off(TARG); } -#endif + /* or mg_get(right) may happen here */ + if (!rcopied) { + rpv = SvPV_const(right, rlen); + rbyte = !DO_UTF8(right); + } if (lbyte != rbyte) { if (lbyte) sv_utf8_upgrade_nomg(TARG); @@ -181,7 +263,7 @@ PP(pp_concat) if (!rcopied) right = sv_2mortal(newSVpvn(rpv, rlen)); sv_utf8_upgrade_nomg(right); - rpv = SvPV(right, rlen); + rpv = SvPV_const(right, rlen); } } sv_catpvn_nomg(TARG, rpv, rlen); @@ -193,12 +275,13 @@ PP(pp_concat) PP(pp_padsv) { - dSP; dTARGET; + dVAR; dSP; dTARGET; XPUSHs(TARG); if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); - else if (PL_op->op_private & OPpDEREF) { + if (!(PL_op->op_private & OPpPAD_STATE)) + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); + if (PL_op->op_private & OPpDEREF) { PUTBACK; vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF); SPAGAIN; @@ -209,6 +292,7 @@ PP(pp_padsv) PP(pp_readline) { + dVAR; tryAMAGICunTARGET(iter, 0); PL_last_in_gv = (GV*)(*PL_stack_sp--); if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { @@ -227,9 +311,9 @@ PP(pp_readline) PP(pp_eq) { - dSP; tryAMAGICbinSET(eq,0); + dVAR; dSP; tryAMAGICbinSET(eq,0); #ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && SvROK(TOPm1s)) { + if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); RETURN; @@ -243,8 +327,8 @@ PP(pp_eq) right argument if we know the left is integer. */ SvIV_please(TOPm1s); if (SvIOK(TOPm1s)) { - bool auvok = SvUOK(TOPm1s); - bool buvok = SvUOK(TOPs); + const bool auvok = SvUOK(TOPm1s); + const bool buvok = SvUOK(TOPs); if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ /* Casting IV to UV before comparison isn't going to matter @@ -253,8 +337,8 @@ PP(pp_eq) differ from normal zero. As I understand it. (Need to check - is negative zero implementation defined behaviour anyway?). NWC */ - UV buv = SvUVX(POPs); - UV auv = SvUVX(TOPs); + const UV buv = SvUVX(POPs); + const UV auv = SvUVX(TOPs); SETs(boolSV(auv == buv)); RETURN; @@ -273,34 +357,40 @@ PP(pp_eq) ivp = *--SP; } iv = SvIVX(ivp); - if (iv < 0) { + if (iv < 0) /* As uv is a UV, it's >0, so it cannot be == */ SETs(&PL_sv_no); - RETURN; - } - /* we know iv is >= 0 */ - SETs(boolSV((UV)iv == SvUVX(uvp))); + else + /* we know iv is >= 0 */ + SETs(boolSV((UV)iv == SvUVX(uvp))); RETURN; } } } #endif { +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + dPOPTOPnnrl; + if (Perl_isnan(left) || Perl_isnan(right)) + RETSETNO; + SETs(boolSV(left == right)); +#else dPOPnv; SETs(boolSV(TOPn == value)); +#endif RETURN; } } PP(pp_preinc) { - dSP; - if (SvTYPE(TOPs) > SVt_PVLV) + dVAR; dSP; + if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) DIE(aTHX_ PL_no_modify); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { - ++SvIVX(TOPs); + SvIV_set(TOPs, SvIVX(TOPs) + 1); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ @@ -311,54 +401,76 @@ PP(pp_preinc) PP(pp_or) { - dSP; + dVAR; dSP; if (SvTRUE(TOPs)) RETURN; else { - --SP; + if (PL_op->op_type == OP_OR) + --SP; RETURNOP(cLOGOP->op_other); } } -PP(pp_dor) +PP(pp_defined) { - /* Most of this is lifted straight from pp_defined */ - dSP; + dVAR; dSP; register SV* sv; - - sv = TOPs; - if (!sv || !SvANY(sv)) { - --SP; - RETURNOP(cLOGOP->op_other); + bool defined; + const int op_type = PL_op->op_type; + const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN); + + if (is_dor) { + sv = TOPs; + if (!sv || !SvANY(sv)) { + if (op_type == OP_DOR) + --SP; + RETURNOP(cLOGOP->op_other); + } } - + else { + /* OP_DEFINED */ + sv = POPs; + if (!sv || !SvANY(sv)) + RETPUSHNO; + } + + defined = FALSE; switch (SvTYPE(sv)) { case SVt_PVAV: if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETURN; + defined = TRUE; break; case SVt_PVHV: if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETURN; + defined = TRUE; break; case SVt_PVCV: if (CvROOT(sv) || CvXSUB(sv)) - RETURN; + defined = TRUE; break; default: - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvOK(sv)) - RETURN; + defined = TRUE; + break; } - - --SP; - RETURNOP(cLOGOP->op_other); + + if (is_dor) { + if(defined) + RETURN; + if(op_type == OP_DOR) + --SP; + RETURNOP(cLOGOP->op_other); + } + /* assuming OP_DEFINED */ + if(defined) + RETPUSHYES; + RETPUSHNO; } PP(pp_add) { - dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); + dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); useleft = USE_LEFT(TOPm1s); #ifdef PERL_PRESERVE_IVUV /* We must see if we can perform the addition with integers if possible, @@ -429,7 +541,7 @@ PP(pp_add) if ((auvok = SvUOK(TOPm1s))) auv = SvUVX(TOPm1s); else { - register IV aiv = SvIVX(TOPm1s); + register const IV aiv = SvIVX(TOPm1s); if (aiv >= 0) { auv = aiv; auvok = 1; /* Now acting as a sign flag. */ @@ -449,7 +561,7 @@ PP(pp_add) if (buvok) buv = SvUVX(TOPs); else { - register IV biv = SvIVX(TOPs); + register const IV biv = SvIVX(TOPs); if (biv >= 0) { buv = biv; buvok = 1; @@ -520,10 +632,11 @@ PP(pp_add) PP(pp_aelemfast) { - dSP; - AV *av = GvAV(cGVOP_gv); - U32 lval = PL_op->op_flags & OPf_MOD; - SV** svp = av_fetch(av, PL_op->op_private, lval); + dVAR; dSP; + AV * const av = PL_op->op_flags & OPf_SPECIAL ? + (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv); + const U32 lval = PL_op->op_flags & OPf_MOD; + SV** const svp = av_fetch(av, PL_op->op_private, lval); SV *sv = (svp ? *svp : &PL_sv_undef); EXTEND(SP, 1); if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ @@ -534,7 +647,7 @@ PP(pp_aelemfast) PP(pp_join) { - dSP; dMARK; dTARGET; + dVAR; dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -544,13 +657,13 @@ PP(pp_join) PP(pp_pushre) { - dSP; + dVAR; dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs * will be enough to hold an OP*. */ - SV* sv = sv_newmortal(); + SV* const sv = sv_newmortal(); sv_upgrade(sv, SVt_PVLV); LvTYPE(sv) = '/'; Copy(&PL_op, &LvTARGOFF(sv), 1, OP*); @@ -565,16 +678,11 @@ PP(pp_pushre) PP(pp_print) { - dSP; dMARK; dORIGMARK; - GV *gv; + dVAR; dSP; dMARK; dORIGMARK; IO *io; register PerlIO *fp; MAGIC *mg; - - if (PL_op->op_flags & OPf_STACKED) - gv = (GV*)*++MARK; - else - gv = PL_defoutgv; + GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv; if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) @@ -645,7 +753,11 @@ PP(pp_print) if (MARK <= SP) goto just_say_no; else { - if (PL_ors_sv && SvOK(PL_ors_sv)) + if (PL_op->op_type == OP_SAY) { + if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp)) + goto just_say_no; + } + else if (PL_ors_sv && SvOK(PL_ors_sv)) if (!do_print(PL_ors_sv, fp)) /* $\ */ goto just_say_no; @@ -655,35 +767,42 @@ PP(pp_print) } } SP = ORIGMARK; - PUSHs(&PL_sv_yes); + XPUSHs(&PL_sv_yes); RETURN; just_say_no: SP = ORIGMARK; - PUSHs(&PL_sv_undef); + XPUSHs(&PL_sv_undef); RETURN; } PP(pp_rv2av) { - dSP; dTOPss; - AV *av; + dVAR; dSP; dTOPss; + const I32 gimme = GIMME_V; + static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context"; + static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context"; + static const char an_array[] = "an ARRAY"; + static const char a_hash[] = "a HASH"; + const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV; + const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; if (SvROK(sv)) { wasref: - tryAMAGICunDEREF(to_av); + tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg); - av = (AV*)SvRV(sv); - if (SvTYPE(av) != SVt_PVAV) - DIE(aTHX_ "Not an ARRAY reference"); + sv = SvRV(sv); + if (SvTYPE(sv) != type) + DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); if (PL_op->op_flags & OPf_REF) { - SETs((SV*)av); + SETs(sv); RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); - SETs((SV*)av); + if (gimme != G_ARRAY) + Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar + : return_hash_to_lvalue_scalar); + SETs(sv); RETURN; } else if (PL_op->op_flags & OPf_MOD @@ -691,17 +810,17 @@ PP(pp_rv2av) Perl_croak(aTHX_ PL_no_localize_ref); } else { - if (SvTYPE(sv) == SVt_PVAV) { - av = (AV*)sv; + if (SvTYPE(sv) == type) { if (PL_op->op_flags & OPf_REF) { - SETs((SV*)av); + SETs(sv); RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return array to lvalue" - " scalar context"); - SETs((SV*)av); + if (gimme != G_ARRAY) + Perl_croak(aTHX_ + is_pp_rv2av ? return_array_to_lvalue_scalar + : return_hash_to_lvalue_scalar); + SETs(sv); RETURN; } } @@ -709,73 +828,54 @@ PP(pp_rv2av) GV *gv; if (SvTYPE(sv) != SVt_PVGV) { - char *sym; - STRLEN len; - if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto wasref; } - if (!SvOK(sv)) { - if (PL_op->op_flags & OPf_REF || - PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_usym, "an ARRAY"); - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); - if (GIMME == G_ARRAY) { - (void)POPs; - RETURN; - } - RETSETUNDEF; - } - sym = SvPV(sv,len); - if ((PL_op->op_flags & OPf_SPECIAL) && - !(PL_op->op_flags & OPf_MOD)) - { - gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); - if (!gv - && (!is_gv_magical(sym,len,0) - || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV)))) - { - RETSETUNDEF; - } - } - else { - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref, sym, "an ARRAY"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV); - } + gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash, + type, &sp); + if (!gv) + RETURN; } else { gv = (GV*)sv; } - av = GvAVn(gv); + sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv); if (PL_op->op_private & OPpLVAL_INTRO) - av = save_ary(gv); + sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv); if (PL_op->op_flags & OPf_REF) { - SETs((SV*)av); + SETs(sv); RETURN; } else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return array to lvalue" - " scalar context"); - SETs((SV*)av); + if (gimme != G_ARRAY) + Perl_croak(aTHX_ + is_pp_rv2av ? return_array_to_lvalue_scalar + : return_hash_to_lvalue_scalar); + SETs(sv); RETURN; } } } - if (GIMME == G_ARRAY) { - I32 maxarg = AvFILL(av) + 1; + if (is_pp_rv2av) { + AV *const av = (AV*)sv; + /* The guts of pp_rv2av, with no intenting change to preserve history + (until such time as we get tools that can do blame annotation across + whitespace changes. */ + if (gimme == G_ARRAY) { + const I32 maxarg = AvFILL(av) + 1; (void)POPs; /* XXXX May be optimized away? */ EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; for (i=0; i < (U32)maxarg; i++) { - SV **svp = av_fetch(av, i, FALSE); - SP[i+1] = (svp) ? *svp : &PL_sv_undef; + SV ** const svp = av_fetch(av, i, FALSE); + /* See note in pp_helem, and bug id #27839 */ + SP[i+1] = svp + ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp + : &PL_sv_undef; } } else { @@ -783,156 +883,50 @@ PP(pp_rv2av) } SP += maxarg; } - else if (GIMME_V == G_SCALAR) { + else if (gimme == G_SCALAR) { dTARGET; - I32 maxarg = AvFILL(av) + 1; + const I32 maxarg = AvFILL(av) + 1; SETi(maxarg); } - RETURN; -} - -PP(pp_rv2hv) -{ - dSP; dTOPss; - HV *hv; - - if (SvROK(sv)) { - wasref: - tryAMAGICunDEREF(to_hv); - - hv = (HV*)SvRV(sv); - if (SvTYPE(hv) != SVt_PVHV) - DIE(aTHX_ "Not a HASH reference"); - if (PL_op->op_flags & OPf_REF) { - SETs((SV*)hv); - RETURN; - } - else if (LVRET) { - if (GIMME != G_SCALAR) - Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); - SETs((SV*)hv); - RETURN; - } - else if (PL_op->op_flags & OPf_MOD - && PL_op->op_private & OPpLVAL_INTRO) - Perl_croak(aTHX_ PL_no_localize_ref); - } - else { - if (SvTYPE(sv) == SVt_PVHV) { - hv = (HV*)sv; - if (PL_op->op_flags & OPf_REF) { - SETs((SV*)hv); - RETURN; - } - else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return hash to lvalue" - " scalar context"); - SETs((SV*)hv); - RETURN; - } - } - else { - GV *gv; - - if (SvTYPE(sv) != SVt_PVGV) { - char *sym; - STRLEN len; - - if (SvGMAGICAL(sv)) { - mg_get(sv); - if (SvROK(sv)) - goto wasref; - } - if (!SvOK(sv)) { - if (PL_op->op_flags & OPf_REF || - PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_usym, "a HASH"); - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(); - if (GIMME == G_ARRAY) { - SP--; - RETURN; - } - RETSETUNDEF; - } - sym = SvPV(sv,len); - if ((PL_op->op_flags & OPf_SPECIAL) && - !(PL_op->op_flags & OPf_MOD)) - { - gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); - if (!gv - && (!is_gv_magical(sym,len,0) - || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV)))) - { - RETSETUNDEF; - } - } - else { - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref, sym, "a HASH"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV); - } - } - else { - gv = (GV*)sv; - } - hv = GvHVn(gv); - if (PL_op->op_private & OPpLVAL_INTRO) - hv = save_hash(gv); - if (PL_op->op_flags & OPf_REF) { - SETs((SV*)hv); - RETURN; - } - else if (LVRET) { - if (GIMME == G_SCALAR) - Perl_croak(aTHX_ "Can't return hash to lvalue" - " scalar context"); - SETs((SV*)hv); - RETURN; - } - } - } - - if (GIMME == G_ARRAY) { /* array wanted */ - *PL_stack_sp = (SV*)hv; + } else { + /* The guts of pp_rv2hv */ + if (gimme == G_ARRAY) { /* array wanted */ + *PL_stack_sp = sv; return do_kv(); } - else { + else if (gimme == G_SCALAR) { dTARGET; - if (HvFILL(hv)) - Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf, - (IV)HvFILL(hv), (IV)HvMAX(hv) + 1); - else - sv_setiv(TARG, 0); - + TARG = Perl_hv_scalar(aTHX_ (HV*)sv); + SPAGAIN; SETTARG; - RETURN; } + } + RETURN; } STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) { + dVAR; if (*relem) { SV *tmpstr; - HE *didstore; + const HE *didstore; if (ckWARN(WARN_MISC)) { + const char *err; if (relem == firstrelem && SvROK(*relem) && (SvTYPE(SvRV(*relem)) == SVt_PVAV || SvTYPE(SvRV(*relem)) == SVt_PVHV)) { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Reference found where even-sized list expected"); + err = "Reference found where even-sized list expected"; } else - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Odd number of elements in hash assignment"); + err = "Odd number of elements in hash assignment"; + Perl_warner(aTHX_ packWARN(WARN_MISC), err); } - tmpstr = NEWSV(29,0); + tmpstr = newSV(0); didstore = hv_store_ent(hash,*relem,tmpstr,0); if (SvMAGICAL(hash)) { if (SvSMAGICAL(tmpstr)) @@ -946,7 +940,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) PP(pp_aassign) { - dSP; + dVAR; dSP; SV **lastlelem = PL_stack_sp; SV **lastrelem = PL_stack_base + POPMARK; SV **firstrelem = PL_stack_base + POPMARK + 1; @@ -962,8 +956,11 @@ PP(pp_aassign) HV *hash; I32 i; int magic; + int duplicates = 0; + SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */ PL_delaymagic = DM_DELAY; /* catch simultaneous items */ + gimme = GIMME_V; /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't @@ -972,7 +969,6 @@ PP(pp_aassign) if (PL_op->op_private & (OPpASSIGN_COMMON)) { EXTEND_MORTAL(lastrelem - firstrelem + 1); for (relem = firstrelem; relem <= lastrelem; relem++) { - /*SUPPRESS 560*/ if ((sv = *relem)) { TAINT_NOT; /* Each item is independent */ *relem = sv_mortalcopy(sv); @@ -982,8 +978,8 @@ PP(pp_aassign) relem = firstrelem; lelem = firstlelem; - ary = Null(AV*); - hash = Null(HV*); + ary = NULL; + hash = NULL; while (lelem <= lastlelem) { TAINT_NOT; /* Each item stands on its own, taintwise. */ @@ -997,9 +993,8 @@ PP(pp_aassign) i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; - sv = NEWSV(28,0); assert(*relem); - sv_setsv(sv,*relem); + sv = newSVsv(*relem); *(relem++) = sv; didstore = av_store(ary,i++,sv); if (magic) { @@ -1017,17 +1012,19 @@ PP(pp_aassign) hash = (HV*)sv; magic = SvMAGICAL(hash) != 0; hv_clear(hash); + firsthashrelem = relem; while (relem < lastrelem) { /* gobble up all the rest */ HE *didstore; - if (*relem) - sv = *(relem++); - else - sv = &PL_sv_no, relem++; - tmpstr = NEWSV(29,0); + sv = *relem ? *relem : &PL_sv_no; + relem++; + tmpstr = newSV(0); if (*relem) sv_setsv(tmpstr,*relem); /* value */ *(relem++) = tmpstr; + if (gimme != G_VOID && hv_exists_ent(hash, sv, 0)) + /* key overwrites an existing entry */ + duplicates += 2; didstore = hv_store_ent(hash,sv,tmpstr,0); if (magic) { if (SvSMAGICAL(tmpstr)) @@ -1062,10 +1059,13 @@ PP(pp_aassign) if (PL_delaymagic & ~DM_DELAY) { if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - (void)setresuid(PL_uid,PL_euid,(Uid_t)-1); + (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, + (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1, + (Uid_t)-1); #else # ifdef HAS_SETREUID - (void)setreuid(PL_uid,PL_euid); + (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, + (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1); # else # ifdef HAS_SETRUID if ((PL_delaymagic & DM_UID) == DM_RUID) { @@ -1075,7 +1075,7 @@ PP(pp_aassign) # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID if ((PL_delaymagic & DM_UID) == DM_EUID) { - (void)seteuid(PL_uid); + (void)seteuid(PL_euid); PL_delaymagic &= ~DM_EUID; } # endif /* HAS_SETEUID */ @@ -1091,10 +1091,13 @@ PP(pp_aassign) } if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - (void)setresgid(PL_gid,PL_egid,(Gid_t)-1); + (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, + (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1, + (Gid_t)-1); #else # ifdef HAS_SETREGID - (void)setregid(PL_gid,PL_egid); + (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, + (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1); # else # ifdef HAS_SETRGID if ((PL_delaymagic & DM_GID) == DM_RGID) { @@ -1104,7 +1107,7 @@ PP(pp_aassign) # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID if ((PL_delaymagic & DM_GID) == DM_EGID) { - (void)setegid(PL_gid); + (void)setegid(PL_egid); PL_delaymagic &= ~DM_EGID; } # endif /* HAS_SETEGID */ @@ -1122,84 +1125,116 @@ PP(pp_aassign) } PL_delaymagic = 0; - gimme = GIMME_V; if (gimme == G_VOID) SP = firstrelem - 1; else if (gimme == G_SCALAR) { dTARGET; SP = firstrelem; - SETi(lastrelem - firstrelem + 1); + SETi(lastrelem - firstrelem + 1 - duplicates); } else { - if (ary || hash) + if (ary) + SP = lastrelem; + else if (hash) { + if (duplicates) { + /* Removes from the stack the entries which ended up as + * duplicated keys in the hash (fix for [perl #24380]) */ + Move(firsthashrelem + duplicates, + firsthashrelem, duplicates, SV**); + lastrelem -= duplicates; + } SP = lastrelem; + } else SP = firstrelem + (lastlelem - firstlelem); lelem = firstlelem + (relem - firstrelem); while (relem <= SP) *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; } + + /* This is done at the bottom and in this order because + mro_isa_changed_in() can throw exceptions */ + if(PL_delayedisa) { + HV* stash = PL_delayedisa; + PL_delayedisa = NULL; + mro_isa_changed_in(stash); + } + RETURN; } PP(pp_qr) { - dSP; - register PMOP *pm = cPMOP; - SV *rv = sv_newmortal(); - SV *sv = newSVrv(rv, "Regexp"); - if (pm->op_pmdynflags & PMdf_TAINTED) + dVAR; dSP; + register PMOP * const pm = cPMOP; + REGEXP * rx = PM_GETRE(pm); + SV * const pkg = CALLREG_PACKAGE(rx); + SV * const rv = sv_newmortal(); + SV * const sv = newSVrv(rv, SvPV_nolen(pkg)); + if (rx->extflags & RXf_TAINTED) SvTAINTED_on(rv); - sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); - RETURNX(PUSHs(rv)); + sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0); + XPUSHs(rv); + RETURN; } PP(pp_match) { - dSP; dTARG; + dVAR; dSP; dTARG; register PMOP *pm = cPMOP; PMOP *dynpm = pm; - register char *t; - register char *s; - char *strend; + register const char *t; + register const char *s; + const char *strend; I32 global; I32 r_flags = REXEC_CHECKED; - char *truebase; /* Start of string */ + const char *truebase; /* Start of string */ register REGEXP *rx = PM_GETRE(pm); bool rxtainted; - I32 gimme = GIMME; + const I32 gimme = GIMME; STRLEN len; I32 minmatch = 0; - I32 oldsave = PL_savestack_ix; + const I32 oldsave = PL_savestack_ix; I32 update_minmatch = 1; I32 had_zerolen = 0; + U32 gpos = 0; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; + else if (PL_op->op_private & OPpTARGET_MY) + GETTARGET; else { TARG = DEFSV; EXTEND(SP,1); } PUTBACK; /* EVAL blocks need stack_sp. */ - s = SvPV(TARG, len); - strend = s + len; + s = SvPV_const(TARG, len); if (!s) DIE(aTHX_ "panic: pp_match"); - rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + strend = s + len; + rxtainted = ((rx->extflags & RXf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); /* PMdf_USED is set after a ?? matches once */ - if (pm->op_pmdynflags & PMdf_USED) { + if ( +#ifdef USE_ITHREADS + SvREADONLY(PL_regex_pad[pm->op_pmoffset]) +#else + pm->op_pmflags & PMf_USED +#endif + ) { failure: if (gimme == G_ARRAY) RETURN; RETPUSHNO; } + + /* empty pattern special-cased to use last successful pattern if possible */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; @@ -1213,60 +1248,71 @@ PP(pp_match) /* XXXX What part of this is needed with true \G-support? */ if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { - rx->startp[0] = -1; + rx->offs[0].start = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); + MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg && mg->mg_len >= 0) { - if (!(rx->reganch & ROPT_GPOS_SEEN)) - rx->endp[0] = rx->startp[0] = mg->mg_len; - else if (rx->reganch & ROPT_ANCH_GPOS) { + if (!(rx->extflags & RXf_GPOS_SEEN)) + rx->offs[0].end = rx->offs[0].start = mg->mg_len; + else if (rx->extflags & RXf_ANCH_GPOS) { r_flags |= REXEC_IGNOREPOS; - rx->endp[0] = rx->startp[0] = mg->mg_len; - } - minmatch = (mg->mg_flags & MGf_MINMATCH); + rx->offs[0].end = rx->offs[0].start = mg->mg_len; + } else if (rx->extflags & RXf_GPOS_FLOAT) + gpos = mg->mg_len; + else + rx->offs[0].end = rx->offs[0].start = mg->mg_len; + minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0; update_minmatch = 0; } } } - if ((!global && rx->nparens) - || SvTEMP(TARG) || PL_sawampersand) + /* XXX: comment out !global get safe $1 vars after a + match, BUT be aware that this leads to drammatic slowdowns on + /g matches against large strings. So far a solution to this problem + appears to be quite tricky. + Test for the unsafe vars are TODO for now. */ + if (( !global && rx->nparens) + || SvTEMP(TARG) || PL_sawampersand || + (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))) r_flags |= REXEC_COPY_STR; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { - SAVEINT(PL_multiline); - PL_multiline = pm->op_pmflags & PMf_MULTILINE; - } - play_it_again: - if (global && rx->startp[0] != -1) { - t = s = rx->endp[0] + truebase; - if ((s + rx->minlen) > strend) + if (global && rx->offs[0].start != -1) { + t = s = rx->offs[0].end + truebase - rx->gofs; + if ((s + rx->minlen) > strend || s < truebase) goto nope; if (update_minmatch++) minmatch = had_zerolen; } - if (rx->reganch & RE_USE_INTUIT && - DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) { - PL_bostr = truebase; - s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + if (rx->extflags & RXf_USE_INTUIT && + DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) { + /* FIXME - can PL_bostr be made const char *? */ + PL_bostr = (char *)truebase; + s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL); if (!s) goto nope; - if ( (rx->reganch & ROPT_CHECK_ALL) + if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand - && ((rx->reganch & ROPT_NOSCAN) - || !((rx->reganch & RE_INTUIT_TAIL) + && !(rx->extflags & RXf_PMf_KEEPCOPY) + && ((rx->extflags & RXf_NOSCAN) + || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM))) && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ goto yup; } - if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) + if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags)) { PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) - dynpm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) { +#ifdef USE_ITHREADS + SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); +#else + dynpm->op_pmflags |= PMf_USED; +#endif + } goto gotcha; } else @@ -1278,25 +1324,20 @@ play_it_again: RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); if (gimme == G_ARRAY) { - I32 nparens, i, len; + const I32 nparens = rx->nparens; + I32 i = (global && !nparens) ? 1 : 0; - nparens = rx->nparens; - if (global && !nparens) - i = 1; - else - i = 0; SPAGAIN; /* EVAL blocks could move the stack. */ EXTEND(SP, nparens + i); EXTEND_MORTAL(nparens + i); for (i = !i; i <= nparens; i++) { PUSHs(sv_newmortal()); - /*SUPPRESS 560*/ - if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { - len = rx->endp[i] - rx->startp[i]; - if (rx->endp[i] < 0 || rx->startp[i] < 0 || + if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) { + const I32 len = rx->offs[i].end - rx->offs[i].start; + s = rx->offs[i].start + truebase; + if (rx->offs[i].end < 0 || rx->offs[i].start < 0 || len < 0 || len > strend - s) DIE(aTHX_ "panic: pp_match start/end pointers"); - s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) SvUTF8_on(*SP); @@ -1304,23 +1345,28 @@ play_it_again: } if (global) { if (dynpm->op_pmflags & PMf_CONTINUE) { - MAGIC* mg = 0; + MAGIC* mg = NULL; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) mg = mg_find(TARG, PERL_MAGIC_regex_global); if (!mg) { - sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); - mg = mg_find(TARG, PERL_MAGIC_regex_global); +#ifdef PERL_OLD_COPY_ON_WRITE + if (SvIsCOW(TARG)) + sv_force_normal_flags(TARG, 0); +#endif + mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, + &PL_vtbl_mglob, NULL, 0); } - if (rx->startp[0] != -1) { - mg->mg_len = rx->endp[0]; - if (rx->startp[0] == rx->endp[0]) + if (rx->offs[0].start != -1) { + mg->mg_len = rx->offs[0].end; + if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; } } - had_zerolen = (rx->startp[0] != -1 - && rx->startp[0] == rx->endp[0]); + had_zerolen = (rx->offs[0].start != -1 + && (rx->offs[0].start + rx->gofs + == (UV)rx->offs[0].end)); PUTBACK; /* EVAL blocks may use stack */ r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; goto play_it_again; @@ -1332,16 +1378,22 @@ play_it_again: } else { if (global) { - MAGIC* mg = 0; + MAGIC* mg; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) mg = mg_find(TARG, PERL_MAGIC_regex_global); + else + mg = NULL; if (!mg) { - sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); - mg = mg_find(TARG, PERL_MAGIC_regex_global); +#ifdef PERL_OLD_COPY_ON_WRITE + if (SvIsCOW(TARG)) + sv_force_normal_flags(TARG, 0); +#endif + mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global, + &PL_vtbl_mglob, NULL, 0); } - if (rx->startp[0] != -1) { - mg->mg_len = rx->endp[0]; - if (rx->startp[0] == rx->endp[0]) + if (rx->offs[0].start != -1) { + mg->mg_len = rx->offs[0].end; + if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; @@ -1356,56 +1408,64 @@ yup: /* Confirmed by INTUIT */ RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); PL_curpm = pm; - if (dynpm->op_pmflags & PMf_ONCE) - dynpm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) { +#ifdef USE_ITHREADS + SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); +#else + dynpm->op_pmflags |= PMf_USED; +#endif + } if (RX_MATCH_COPIED(rx)) Safefree(rx->subbeg); RX_MATCH_COPIED_off(rx); - rx->subbeg = Nullch; + rx->subbeg = NULL; if (global) { - rx->subbeg = truebase; - rx->startp[0] = s - truebase; + /* FIXME - should rx->subbeg be const char *? */ + rx->subbeg = (char *) truebase; + rx->offs[0].start = s - truebase; if (RX_MATCH_UTF8(rx)) { - char *t = (char*)utf8_hop((U8*)s, rx->minlen); - rx->endp[0] = t - truebase; + char * const t = (char*)utf8_hop((U8*)s, rx->minlenret); + rx->offs[0].end = t - truebase; } else { - rx->endp[0] = s - truebase + rx->minlen; + rx->offs[0].end = s - truebase + rx->minlenret; } rx->sublen = strend - truebase; goto gotcha; } - if (PL_sawampersand) { + if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) { I32 off; -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) { if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n", - (int) SvTYPE(TARG), truebase, t, + (int) SvTYPE(TARG), (void*)truebase, (void*)t, (int)(t-truebase)); } rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG); - rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase); + rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase); assert (SvPOKp(rx->saved_copy)); } else #endif { rx->subbeg = savepvn(t, strend - t); -#ifdef PERL_COPY_ON_WRITE - rx->saved_copy = Nullsv; +#ifdef PERL_OLD_COPY_ON_WRITE + rx->saved_copy = NULL; #endif } rx->sublen = strend - t; RX_MATCH_COPIED_on(rx); - off = rx->startp[0] = s - t; - rx->endp[0] = off + rx->minlen; + off = rx->offs[0].start = s - t; + rx->offs[0].end = off + rx->minlenret; } else { /* startp/endp are used by @- @+. */ - rx->startp[0] = s - truebase; - rx->endp[0] = s - truebase + rx->minlen; + rx->offs[0].start = s - truebase; + rx->offs[0].end = s - truebase + rx->minlenret; } + /* including rx->nparens in the below code seems highly suspicious. + -dmq */ rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */ LEAVE_SCOPE(oldsave); RETPUSHYES; @@ -1414,7 +1474,7 @@ nope: ret_no: if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); + MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg) mg->mg_len = -1; } @@ -1428,32 +1488,34 @@ ret_no: OP * Perl_do_readline(pTHX) { - dSP; dTARGETSTACKED; + dVAR; dSP; dTARGETSTACKED; register SV *sv; STRLEN tmplen = 0; STRLEN offset; PerlIO *fp; - register IO *io = GvIO(PL_last_in_gv); - register I32 type = PL_op->op_type; - I32 gimme = GIMME_V; - MAGIC *mg; + register IO * const io = GvIO(PL_last_in_gv); + register const I32 type = PL_op->op_type; + const I32 gimme = GIMME_V; - if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)io, mg)); - PUTBACK; - ENTER; - call_method("READLINE", gimme); - LEAVE; - SPAGAIN; - if (gimme == G_SCALAR) { - SV* result = POPs; - SvSetSV_nosteal(TARG, result); - PUSHTARG; + if (io) { + MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar); + if (mg) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)io, mg)); + PUTBACK; + ENTER; + call_method("READLINE", gimme); + LEAVE; + SPAGAIN; + if (gimme == G_SCALAR) { + SV* const result = POPs; + SvSetSV_nosteal(TARG, result); + PUSHTARG; + } + RETURN; } - RETURN; } - fp = Nullfp; + fp = NULL; if (io) { fp = IoIFP(io); if (!fp) { @@ -1462,8 +1524,8 @@ Perl_do_readline(pTHX) IoLINES(io) = 0; if (av_len(GvAVn(PL_last_in_gv)) < 0) { IoFLAGS(io) &= ~IOf_START; - do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); - sv_setpvn(GvSV(PL_last_in_gv), "-", 1); + do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL); + sv_setpvn(GvSVn(PL_last_in_gv), "-", 1); SvSETMAGIC(GvSV(PL_last_in_gv)); fp = IoIFP(io); goto have_fp; @@ -1484,8 +1546,9 @@ Perl_do_readline(pTHX) } } if (!fp) { - if (ckWARN2(WARN_GLOB, WARN_CLOSED) - && (!io || !(IoFLAGS(io) & IOf_START))) { + if ((!io || !(IoFLAGS(io) & IOf_START)) + && ckWARN2(WARN_GLOB, WARN_CLOSED)) + { if (type == OP_GLOB) Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", @@ -1497,7 +1560,7 @@ Perl_do_readline(pTHX) /* undef TARG, and push that undefined value */ if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - (void)SvOK_off(TARG); + SvOK_off(TARG); } PUSHTARG; } @@ -1506,23 +1569,31 @@ Perl_do_readline(pTHX) have_fp: if (gimme == G_SCALAR) { sv = TARG; - if (SvROK(sv)) - sv_unref(sv); - (void)SvUPGRADE(sv, SVt_PV); + if (type == OP_RCATLINE && SvGMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) { + if (type == OP_RCATLINE) + SvPV_force_nolen(sv); + else + sv_unref(sv); + } + else if (isGV_with_GP(sv)) { + SvPV_force_nolen(sv); + } + SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ if (!tmplen && !SvREADONLY(sv)) Sv_Grow(sv, 80); /* try short-buffering it */ offset = 0; if (type == OP_RCATLINE && SvOK(sv)) { if (!SvPOK(sv)) { - STRLEN n_a; - (void)SvPV_force(sv, n_a); + SvPV_force_nolen(sv); } offset = SvCUR(sv); } } else { - sv = sv_2mortal(NEWSV(57, 80)); + sv = sv_2mortal(newSV(80)); offset = 0; } @@ -1541,7 +1612,9 @@ Perl_do_readline(pTHX) for (;;) { PUTBACK; if (!sv_gets(sv, fp, offset) - && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv))) + && (type == OP_GLOB + || SNARF_EOF(gimme, PL_rs, io, sv) + || PerlIO_error(fp))) { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { @@ -1561,7 +1634,7 @@ Perl_do_readline(pTHX) if (gimme == G_SCALAR) { if (type != OP_RCATLINE) { SV_CHECK_THINKFIRST_COW_DROP(TARG); - (void)SvOK_off(TARG); + SvOK_off(TARG); } SPAGAIN; PUSHTARG; @@ -1576,39 +1649,48 @@ Perl_do_readline(pTHX) SPAGAIN; XPUSHs(sv); if (type == OP_GLOB) { - char *tmps; + const char *t1; if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { - tmps = SvEND(sv) - 1; - if (*tmps == *SvPVX(PL_rs)) { + char * const tmps = SvEND(sv) - 1; + if (*tmps == *SvPVX_const(PL_rs)) { *tmps = '\0'; - SvCUR(sv)--; + SvCUR_set(sv, SvCUR(sv) - 1); } } - for (tmps = SvPVX(sv); *tmps; tmps++) - if (!isALPHA(*tmps) && !isDIGIT(*tmps) && - strchr("$&*(){}[]'\";\\|?<>~`", *tmps)) + for (t1 = SvPVX_const(sv); *t1; t1++) + if (!isALPHA(*t1) && !isDIGIT(*t1) && + strchr("$&*(){}[]'\";\\|?<>~`", *t1)) break; - if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) { + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } + } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ + if (ckWARN(WARN_UTF8)) { + const U8 * const s = (const U8*)SvPVX_const(sv) + offset; + const STRLEN len = SvCUR(sv) - offset; + const U8 *f; + + if (!is_utf8_string_loc(s, len, &f)) + /* Emulate :encoding(utf8) warning in the same case. */ + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "utf8 \"\\x%02X\" does not map to Unicode", + f < (U8*)SvEND(sv) ? *f : 0); + } } if (gimme == G_ARRAY) { if (SvLEN(sv) - SvCUR(sv) > 20) { - SvLEN_set(sv, SvCUR(sv)+1); - Renew(SvPVX(sv), SvLEN(sv), char); + SvPV_shrink_to_cur(sv); } - sv = sv_2mortal(NEWSV(58, 80)); + sv = sv_2mortal(newSV(80)); continue; } else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { /* try to reclaim a bit of scalar space (only on 1st alloc) */ - if (SvCUR(sv) < 60) - SvLEN_set(sv, 80); - else - SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */ - Renew(SvPVX(sv), SvLEN(sv), char); + const STRLEN new_len + = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ + SvPV_renew(sv, new_len); } RETURN; } @@ -1616,7 +1698,7 @@ Perl_do_readline(pTHX) PP(pp_enter) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme = OP_GIMME(PL_op, -1); @@ -1637,73 +1719,65 @@ PP(pp_enter) PP(pp_helem) { - dSP; + dVAR; dSP; HE* he; SV **svp; - SV *keysv = POPs; - HV *hv = (HV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD || LVRET; - U32 defer = PL_op->op_private & OPpLVAL_DEFER; + SV * const keysv = POPs; + HV * const hv = (HV*)POPs; + const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; + const U32 defer = PL_op->op_private & OPpLVAL_DEFER; SV *sv; -#ifdef PERL_COPY_ON_WRITE - U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0; -#else - U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0; -#endif + const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0; I32 preeminent = 0; - if (SvTYPE(hv) == SVt_PVHV) { - if (PL_op->op_private & OPpLVAL_INTRO) { - MAGIC *mg; - HV *stash; - /* does the element we're localizing already exist? */ - preeminent = - /* can we determine whether it exists? */ - ( !SvRMAGICAL(hv) - || mg_find((SV*)hv, PERL_MAGIC_env) - || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied)) - /* Try to preserve the existenceness of a tied hash - * element by using EXISTS and DELETE if possible. - * Fallback to FETCH and STORE otherwise */ - && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) - && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) - && gv_fetchmethod_autoload(stash, "DELETE", TRUE) - ) - ) ? hv_exists_ent(hv, keysv, 0) : 1; - - } - he = hv_fetch_ent(hv, keysv, lval && !defer, hash); - svp = he ? &HeVAL(he) : 0; - } - else { + if (SvTYPE(hv) != SVt_PVHV) RETPUSHUNDEF; - } + + if (PL_op->op_private & OPpLVAL_INTRO) { + MAGIC *mg; + HV *stash; + /* does the element we're localizing already exist? */ + preeminent = /* can we determine whether it exists? */ + ( !SvRMAGICAL(hv) + || mg_find((SV*)hv, PERL_MAGIC_env) + || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied)) + /* Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise */ + && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) + && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) + && gv_fetchmethod_autoload(stash, "DELETE", TRUE) + ) + ) ? hv_exists_ent(hv, keysv, 0) : 1; + } + he = hv_fetch_ent(hv, keysv, lval && !defer, hash); + svp = he ? &HeVAL(he) : NULL; if (lval) { if (!svp || *svp == &PL_sv_undef) { SV* lv; SV* key2; if (!defer) { - STRLEN n_a; - DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); } lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0); + sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); SvREFCNT_dec(key2); /* sv_magic() increments refcount */ - LvTARG(lv) = SvREFCNT_inc(hv); + LvTARG(lv) = SvREFCNT_inc_simple(hv); LvTARGLEN(lv) = 1; PUSHs(lv); RETURN; } if (PL_op->op_private & OPpLVAL_INTRO) { - if (HvNAME(hv) && isGV(*svp)) + if (HvNAME_get(hv) && isGV(*svp)) save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); else { if (!preeminent) { STRLEN keylen; - char *key = SvPV(keysv, keylen); - SAVEDELETE(hv, savepvn(key,keylen), keylen); + const char * const key = SvPV_const(keysv, keylen); + SAVEDELETE(hv, savepvn(key,keylen), + SvUTF8(keysv) ? -(I32)keylen : (I32)keylen); } else save_helem(hv, keysv, svp); } @@ -1726,9 +1800,8 @@ PP(pp_helem) PP(pp_leave) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -1752,6 +1825,7 @@ PP(pp_leave) if (gimme == G_VOID) SP = newsp; else if (gimme == G_SCALAR) { + register SV **mark; MARK = newsp + 1; if (MARK <= SP) { if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) @@ -1766,6 +1840,7 @@ PP(pp_leave) } else if (gimme == G_ARRAY) { /* in case LEAVE wipes old return values */ + register SV **mark; for (mark = newsp + 1; mark <= SP; mark++) { if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { *mark = sv_mortalcopy(*mark); @@ -1782,9 +1857,9 @@ PP(pp_leave) PP(pp_iter) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; - SV* sv; + SV *sv, *oldsv; AV* av; SV **itersvp; @@ -1800,8 +1875,10 @@ PP(pp_iter) if (cx->blk_loop.iterlval) { /* string increment */ register SV* cur = cx->blk_loop.iterlval; - STRLEN maxlen; - char *max = SvPV((SV*)av, maxlen); + STRLEN maxlen = 0; + const char *max = + SvOK((SV*)av) ? + SvPV_const((SV*)av, maxlen) : (const char *)""; if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ @@ -1812,10 +1889,11 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as * they used to */ - SvREFCNT_dec(*itersvp); + oldsv = *itersvp; *itersvp = newSVsv(cur); + SvREFCNT_dec(oldsv); } - if (strEQ(SvPVX(cur), max)) + if (strEQ(SvPVX_const(cur), max)) sv_setiv(cur, 0); /* terminate next time */ else sv_inc(cur); @@ -1837,32 +1915,44 @@ PP(pp_iter) /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they * used to */ - SvREFCNT_dec(*itersvp); + oldsv = *itersvp; *itersvp = newSViv(cx->blk_loop.iterix++); + SvREFCNT_dec(oldsv); } RETPUSHYES; } /* iterate array */ - if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) - RETPUSHNO; - - SvREFCNT_dec(*itersvp); + if (PL_op->op_private & OPpITER_REVERSED) { + /* In reverse, use itermax as the min :-) */ + if (cx->blk_loop.iterix <= cx->blk_loop.itermax) + RETPUSHNO; - if (SvMAGICAL(av) || AvREIFY(av)) { - SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); - if (svp) - sv = *svp; - else - sv = Nullsv; + if (SvMAGICAL(av) || AvREIFY(av)) { + SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE); + sv = svp ? *svp : NULL; + } + else { + sv = AvARRAY(av)[--cx->blk_loop.iterix]; + } } else { - sv = AvARRAY(av)[++cx->blk_loop.iterix]; + if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : + AvFILL(av))) + RETPUSHNO; + + if (SvMAGICAL(av) || AvREIFY(av)) { + SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); + sv = svp ? *svp : NULL; + } + else { + sv = AvARRAY(av)[++cx->blk_loop.iterix]; + } } - if (sv && SvREFCNT(sv) == 0) { - *itersvp = Nullsv; - Perl_croak(aTHX_ - "Use of freed value in iteration (perhaps you modified the iterated array within the loop?)"); + + if (sv && SvIS_FREED(sv)) { + *itersvp = NULL; + Perl_croak(aTHX_ "Use of freed value in iteration"); } if (sv) @@ -1873,36 +1963,37 @@ PP(pp_iter) SV *lv = cx->blk_loop.iterlval; if (lv && SvREFCNT(lv) > 1) { SvREFCNT_dec(lv); - lv = Nullsv; + lv = NULL; } if (lv) SvREFCNT_dec(LvTARG(lv)); else { - lv = cx->blk_loop.iterlval = NEWSV(26, 0); - sv_upgrade(lv, SVt_PVLV); + lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); + sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); } - LvTARG(lv) = SvREFCNT_inc(av); + LvTARG(lv) = SvREFCNT_inc_simple(av); LvTARGOFF(lv) = cx->blk_loop.iterix; LvTARGLEN(lv) = (STRLEN)UV_MAX; sv = (SV*)lv; } - *itersvp = SvREFCNT_inc(sv); + oldsv = *itersvp; + *itersvp = SvREFCNT_inc_simple_NN(sv); + SvREFCNT_dec(oldsv); + RETPUSHYES; } PP(pp_subst) { - dSP; dTARG; + dVAR; dSP; dTARG; register PMOP *pm = cPMOP; PMOP *rpm = pm; - register SV *dstr; register char *s; char *strend; register char *m; - char *c; + const char *c; register char *d; STRLEN clen; I32 iters = 0; @@ -1915,24 +2006,26 @@ PP(pp_subst) register REGEXP *rx = PM_GETRE(pm); STRLEN len; int force_on_match = 0; - I32 oldsave = PL_savestack_ix; + const I32 oldsave = PL_savestack_ix; STRLEN slen; bool doutf8 = FALSE; -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE bool is_cow; #endif - SV *nsv = Nullsv; + SV *nsv = NULL; /* known replacement string? */ - dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; + register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL; if (PL_op->op_flags & OPf_STACKED) TARG = POPs; + else if (PL_op->op_private & OPpTARGET_MY) + GETTARGET; else { TARG = DEFSV; EXTEND(SP,1); } -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE /* Awooga. Awooga. "bool" types that are actually char are dangerous, because they make integers such as 256 "false". */ is_cow = SvIsCOW(TARG) ? TRUE : FALSE; @@ -1941,19 +2034,20 @@ PP(pp_subst) sv_force_normal_flags(TARG,0); #endif if ( -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE !is_cow && #endif (SvREADONLY(TARG) - || (SvTYPE(TARG) > SVt_PVLV - && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) + || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) + || SvTYPE(TARG) > SVt_PVLV) + && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) DIE(aTHX_ PL_no_modify); PUTBACK; - s = SvPV(TARG, len); + s = SvPV_mutable(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; - rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || + rxtainted = ((rx->extflags & RXf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); if (PL_tainted) rxtainted |= 2; @@ -1975,26 +2069,25 @@ PP(pp_subst) pm = PL_curpm; rx = PM_GETRE(pm); } - r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) + r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand + || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) ) ? REXEC_COPY_STR : 0; if (SvSCREAM(TARG)) r_flags |= REXEC_SCREAM; - if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) { - SAVEINT(PL_multiline); - PL_multiline = pm->op_pmflags & PMf_MULTILINE; - } + orig = m = s; - if (rx->reganch & RE_USE_INTUIT) { + if (rx->extflags & RXf_USE_INTUIT) { PL_bostr = orig; - s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); + s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL); if (!s) goto nope; /* How to do it in subst? */ -/* if ( (rx->reganch & ROPT_CHECK_ALL) +/* if ( (rx->extflags & RXf_CHECK_ALL) && !PL_sawampersand - && ((rx->reganch & ROPT_NOSCAN) - || !((rx->reganch & RE_INTUIT_TAIL) + && !(rx->extflags & RXf_KEEPCOPY) + && ((rx->extflags & RXf_NOSCAN) + || !((rx->extflags & RXf_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) goto yup; */ @@ -2013,28 +2106,28 @@ PP(pp_subst) sv_recode_to_utf8(nsv, PL_encoding); else sv_utf8_upgrade(nsv); - c = SvPV(nsv, clen); + c = SvPV_const(nsv, clen); doutf8 = TRUE; } else { - c = SvPV(dstr, clen); + c = SvPV_const(dstr, clen); doutf8 = DO_UTF8(dstr); } } else { - c = Nullch; + c = NULL; doutf8 = FALSE; } /* can do inplace substitution? */ if (c -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE && !is_cow #endif - && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) - && !(rx->reganch & ROPT_LOOKBEHIND_SEEN) + && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR)) + && !(rx->extflags & RXf_LOOKBEHIND_SEEN) && (!doutf8 || SvUTF8(TARG))) { - if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { SPAGAIN; @@ -2042,7 +2135,7 @@ PP(pp_subst) LEAVE_SCOPE(oldsave); RETURN; } -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(TARG)) { assert (!force_on_match); goto have_a_cow; @@ -2058,8 +2151,8 @@ PP(pp_subst) SvSCREAM_off(TARG); /* disable possible screamer */ if (once) { rxtainted |= RX_MATCH_TAINTED(rx); - m = orig + rx->startp[0]; - d = orig + rx->endp[0]; + m = orig + rx->offs[0].start; + d = orig + rx->offs[0].end; s = orig; if (m - s > strend - d) { /* faster to shorten from end */ if (clen) { @@ -2074,7 +2167,6 @@ PP(pp_subst) *m = '\0'; SvCUR_set(TARG, m - s); } - /*SUPPRESS 560*/ else if ((i = m - s)) { /* faster from front */ d -= clen; m = d; @@ -2102,8 +2194,7 @@ PP(pp_subst) if (iters++ > maxiters) DIE(aTHX_ "Substitution loop"); rxtainted |= RX_MATCH_TAINTED(rx); - m = rx->startp[0] + orig; - /*SUPPRESS 560*/ + m = rx->offs[0].start + orig; if ((i = m - s)) { if (s != d) Move(s, d, i, char); @@ -2113,14 +2204,14 @@ PP(pp_subst) Copy(c, d, clen, char); d += clen; } - s = rx->endp[0] + orig; - } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + s = rx->offs[0].end + orig; + } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, /* don't match same null twice */ REXEC_NOT_FIRST|REXEC_IGNOREPOS)); if (s != d) { i = strend - s; - SvCUR_set(TARG, d - SvPVX(TARG) + i); + SvCUR_set(TARG, d - SvPVX_const(TARG) + i); Move(s, d, i+1, char); /* include the NUL */ } TAINT_IF(rxtainted & 1); @@ -2141,7 +2232,7 @@ PP(pp_subst) RETURN; } - if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, + if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { if (force_on_match) { @@ -2149,21 +2240,20 @@ PP(pp_subst) s = SvPV_force(TARG, len); goto force_it; } -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE have_a_cow: #endif rxtainted |= RX_MATCH_TAINTED(rx); - dstr = NEWSV(25, len); - sv_setpvn(dstr, m, s-m); + dstr = newSVpvn(m, s-m); + SAVEFREESV(dstr); if (DO_UTF8(TARG)) SvUTF8_on(dstr); PL_curpm = pm; if (!c) { register PERL_CONTEXT *cx; SPAGAIN; - ReREFCNT_inc(rx); PUSHSUBST(cx); - RETURNOP(cPMOP->op_pmreplroot); + RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); } r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; do { @@ -2177,24 +2267,24 @@ PP(pp_subst) s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0] + orig; + m = rx->offs[0].start + orig; if (doutf8 && !SvUTF8(dstr)) sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); else sv_catpvn(dstr, s, m-s); - s = rx->endp[0] + orig; + s = rx->offs[0].end + orig; if (clen) sv_catpvn(dstr, c, clen); if (once) break; - } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, + } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags)); if (doutf8 && !DO_UTF8(TARG)) sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv); else sv_catpvn(dstr, s, strend - s); -#ifdef PERL_COPY_ON_WRITE +#ifdef PERL_OLD_COPY_ON_WRITE /* The match may make the string COW. If so, brilliant, because that's just saved us one malloc, copy and free - the regexp has donated the old buffer, and we malloc an entirely new one, rather than the @@ -2205,16 +2295,13 @@ PP(pp_subst) } else #endif { - (void)SvOOK_off(TARG); - if (SvLEN(TARG)) - Safefree(SvPVX(TARG)); + SvPV_free(TARG); } - SvPVX(TARG) = SvPVX(dstr); + SvPV_set(TARG, SvPVX(dstr)); SvCUR_set(TARG, SvCUR(dstr)); SvLEN_set(TARG, SvLEN(dstr)); doutf8 |= DO_UTF8(dstr); - SvPVX(dstr) = 0; - sv_free(dstr); + SvPV_set(dstr, NULL); TAINT_IF(rxtainted & 1); SPAGAIN; @@ -2241,7 +2328,7 @@ ret_no: PP(pp_grepwhile) { - dSP; + dVAR; dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -2251,7 +2338,7 @@ PP(pp_grepwhile) /* All done yet? */ if (PL_stack_base + *PL_markstack_ptr > SP) { I32 items; - I32 gimme = GIMME_V; + const I32 gimme = GIMME_V; LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ @@ -2259,8 +2346,15 @@ PP(pp_grepwhile) (void)POPMARK; /* pop dst */ SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { - dTARGET; - XPUSHi(items); + if (PL_op->op_private & OPpGREP_LEX) { + SV* const sv = sv_newmortal(); + sv_setiv(sv, items); + PUSHs(sv); + } + else { + dTARGET; + XPUSHi(items); + } } else if (gimme == G_ARRAY) SP += items; @@ -2274,7 +2368,10 @@ PP(pp_grepwhile) src = PL_stack_base[*PL_markstack_ptr]; SvTEMP_off(src); - DEFSV = src; + if (PL_op->op_private & OPpGREP_LEX) + PAD_SVl(PL_op->op_targ) = src; + else + DEFSV = src; RETURNOP(cLOGOP->op_other); } @@ -2282,7 +2379,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - dSP; + dVAR; dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2290,6 +2387,9 @@ PP(pp_leavesub) register PERL_CONTEXT *cx; SV *sv; + if (CxMULTICALL(&cxstack[cxstack_ix])) + return 0; + POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2335,14 +2435,14 @@ PP(pp_leavesub) PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); - return pop_return(); + return cx->blk_sub.retop; } /* This duplicates the above code because the above code must not * get any slower by more conditions */ PP(pp_leavesublv) { - dSP; + dVAR; dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2350,6 +2450,9 @@ PP(pp_leavesublv) register PERL_CONTEXT *cx; SV *sv; + if (CxMULTICALL(&cxstack[cxstack_ix])) + return 0; + POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2371,13 +2474,13 @@ PP(pp_leavesublv) EXTEND_MORTAL(SP - newsp); for (mark = newsp + 1; mark <= SP; mark++) { if (SvTEMP(*mark)) - /* empty */ ; + NOOP; else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY)) *mark = sv_mortalcopy(*mark); else { /* Can be a localized value subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; - (void)SvREFCNT_inc(*mark); + SvREFCNT_inc_void(*mark); } } } @@ -2398,7 +2501,10 @@ PP(pp_leavesublv) MARK = newsp + 1; EXTEND_MORTAL(1); if (MARK == SP) { - if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + /* Temporaries are bad unless they happen to be elements + * of a tied hash or array */ + if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) && + !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) { LEAVE; cxstack_ix--; POPSUB(cx,sv); @@ -2411,7 +2517,7 @@ PP(pp_leavesublv) else { /* Can be a localized value * subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; - (void)SvREFCNT_inc(*mark); + SvREFCNT_inc_void(*mark); } } else { /* Should not happen? */ @@ -2443,7 +2549,7 @@ PP(pp_leavesublv) else { /* Can be a localized value subject to deletion. */ PL_tmps_stack[++PL_tmps_ix] = *mark; - (void)SvREFCNT_inc(*mark); + SvREFCNT_inc_void(*mark); } } } @@ -2493,64 +2599,27 @@ PP(pp_leavesublv) PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); - return pop_return(); -} - - -STATIC CV * -S_get_db_sub(pTHX_ SV **svp, CV *cv) -{ - SV *dbsv = GvSV(PL_DBsub); - - if (!PERLDB_SUB_NN) { - GV *gv = CvGV(cv); - - save_item(dbsv); - if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) - || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) - && (gv = (GV*)*svp) ))) { - /* Use GV from the stack as a fallback. */ - /* GV is potentially non-unique, or contain different CV. */ - SV *tmp = newRV((SV*)cv); - sv_setsv(dbsv, tmp); - SvREFCNT_dec(tmp); - } - else { - gv_efullname3(dbsv, gv, Nullch); - } - } - else { - (void)SvUPGRADE(dbsv, SVt_PVIV); - (void)SvIOK_on(dbsv); - SAVEIV(SvIVX(dbsv)); - SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */ - } - - if (CvXSUB(cv)) - PL_curcopdb = PL_curcop; - cv = GvCV(PL_DBsub); - return cv; + return cx->blk_sub.retop; } PP(pp_entersub) { - dSP; dPOPss; + dVAR; dSP; dPOPss; GV *gv; - HV *stash; register CV *cv; register PERL_CONTEXT *cx; I32 gimme; - bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; + const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; if (!sv) DIE(aTHX_ "Not a CODE reference"); switch (SvTYPE(sv)) { /* This is overwhelming the most common case: */ case SVt_PVGV: - if (!(cv = GvCVu((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, FALSE); + if (!(cv = GvCVu((GV*)sv))) { + HV *stash; + cv = sv_2cv(sv, &stash, &gv, 0); + } if (!cv) { ENTER; SAVETMPS; @@ -2559,9 +2628,8 @@ PP(pp_entersub) break; default: if (!SvROK(sv)) { - char *sym; - STRLEN n_a; - + const char *sym; + STRLEN len; if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) SP = PL_stack_base + POPMARK; @@ -2571,20 +2639,27 @@ PP(pp_entersub) mg_get(sv); if (SvROK(sv)) goto got_rv; - sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; + if (SvPOKp(sv)) { + sym = SvPVX_const(sv); + len = SvCUR(sv); + } else { + sym = NULL; + len = 0; + } } - else - sym = SvPV(sv, n_a); + else { + sym = SvPV_const(sv, len); + } if (!sym) DIE(aTHX_ PL_no_usym, "a subroutine"); if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_symref, sym, "a subroutine"); - cv = get_cv(sym, TRUE); + cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv)); break; } got_rv: { - SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); } cv = (CV*)SvRV(sv); @@ -2605,50 +2680,70 @@ PP(pp_entersub) retry: if (!CvROOT(cv) && !CvXSUB(cv)) { - goto fooey; + GV* autogv; + SV* sub_name; + + /* anonymous or undef'd function leaves us no recourse */ + if (CvANON(cv) || !(gv = CvGV(cv))) + DIE(aTHX_ "Undefined subroutine called"); + + /* autoloaded stub? */ + if (cv != GvCV(gv)) { + cv = GvCV(gv); + } + /* should call AUTOLOAD now? */ + else { +try_autoload: + if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + FALSE))) + { + cv = GvCV(autogv); + } + /* sorry */ + else { + sub_name = sv_newmortal(); + gv_efullname3(sub_name, gv, NULL); + DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name)); + } + } + if (!cv) + DIE(aTHX_ "Not a CODE reference"); + goto retry; } gimme = GIMME_V; if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { - if (CvASSERTION(cv) && PL_DBassertion) - sv_setiv(PL_DBassertion, 1); - - cv = get_db_sub(&sv, cv); - if (!cv) - DIE(aTHX_ "No DBsub routine"); + Perl_get_db_sub(aTHX_ &sv, cv); + if (CvISXSUB(cv)) + PL_curcopdb = PL_curcop; + cv = GvCV(PL_DBsub); + + if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) + DIE(aTHX_ "No DB::sub routine defined"); } - if (!(CvXSUB(cv))) { + if (!(CvISXSUB(cv))) { /* This path taken at least 75% of the time */ dMARK; register I32 items = SP - MARK; - AV* padlist = CvPADLIST(cv); - push_return(PL_op->op_next); + AV* const padlist = CvPADLIST(cv); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); + cx->blk_sub.retop = PL_op->op_next; CvDEPTH(cv)++; /* XXX This would be a natural place to set C so * that eval'' ops within this sub know the correct lexical space. * Owing the speed considerations, we choose instead to search for * the cv using find_runcv() when calling doeval(). */ - if (CvDEPTH(cv) < 2) - (void)SvREFCNT_inc(cv); - else { + if (CvDEPTH(cv) >= 2) { PERL_STACK_OVERFLOW_CHECK(); - pad_push(padlist, CvDEPTH(cv), 1); + pad_push(padlist, CvDEPTH(cv)); } - PAD_SET_CUR(padlist, CvDEPTH(cv)); - if (hasargs) - { - AV* av; - SV** ary; - -#if 0 - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p entersub preparing @_\n", thr)); -#endif - av = (AV*)PAD_SVl(0); + SAVECOMPPAD(); + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); + if (hasargs) { + AV* const av = (AV*)PAD_SVl(0); if (AvREAL(av)) { /* @_ is normally not REAL--this should only ever * happen when DB::sub() calls things that modify @_ */ @@ -2657,22 +2752,22 @@ PP(pp_entersub) AvREIFY_on(av); } cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; ++MARK; if (items > AvMAX(av) + 1) { - ary = AvALLOC(av); + SV **ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPVX(av) = (char*)ary; + AvARRAY(av) = ary; } if (items > AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items,SV*); AvALLOC(av) = ary; - SvPVX(av) = (char*)ary; + AvARRAY(av) = ary; } } Copy(MARK,AvARRAY(av),items,SV*); @@ -2693,109 +2788,51 @@ PP(pp_entersub) sub_crush_depth(cv); #if 0 DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p entersub returning %p\n", thr, CvSTART(cv))); + "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv))); #endif RETURNOP(CvSTART(cv)); } else { -#ifdef PERL_XSUB_OLDSTYLE - if (CvOLDSTYLE(cv)) { - I32 (*fp3)(int,int,int); - dMARK; - register I32 items = SP - MARK; - /* We dont worry to copy from @_. */ - while (SP > mark) { - SP[1] = SP[0]; - SP--; - } - PL_stack_sp = mark + 1; - fp3 = (I32(*)(int,int,int))CvXSUB(cv); - items = (*fp3)(CvXSUBANY(cv).any_i32, - MARK - PL_stack_base + 1, - items); - PL_stack_sp = PL_stack_base + items; - } - else -#endif /* PERL_XSUB_OLDSTYLE */ - { - I32 markix = TOPMARK; + I32 markix = TOPMARK; - PUTBACK; + PUTBACK; - if (!hasargs) { - /* Need to copy @_ to stack. Alternative may be to - * switch stack to @_, and copy return values - * back. This would allow popping @_ in XSUB, e.g.. XXXX */ - AV* av; - I32 items; - av = GvAV(PL_defgv); - items = AvFILLp(av) + 1; /* @_ is not tieable */ - - if (items) { - /* Mark is at the end of the stack. */ - EXTEND(SP, items); - Copy(AvARRAY(av), SP + 1, items, SV*); - SP += items; - PUTBACK ; - } - } - /* We assume first XSUB in &DB::sub is the called one. */ - if (PL_curcopdb) { - SAVEVPTR(PL_curcop); - PL_curcop = PL_curcopdb; - PL_curcopdb = NULL; - } - /* Do we need to open block here? XXXX */ + if (!hasargs) { + /* Need to copy @_ to stack. Alternative may be to + * switch stack to @_, and copy return values + * back. This would allow popping @_ in XSUB, e.g.. XXXX */ + AV * const av = GvAV(PL_defgv); + const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */ + + if (items) { + /* Mark is at the end of the stack. */ + EXTEND(SP, items); + Copy(AvARRAY(av), SP + 1, items, SV*); + SP += items; + PUTBACK ; + } + } + /* We assume first XSUB in &DB::sub is the called one. */ + if (PL_curcopdb) { + SAVEVPTR(PL_curcop); + PL_curcop = PL_curcopdb; + PL_curcopdb = NULL; + } + /* Do we need to open block here? XXXX */ + if (CvXSUB(cv)) /* XXX this is supposed to be true */ (void)(*CvXSUB(cv))(aTHX_ cv); - /* Enforce some sanity in scalar context. */ - if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { - if (markix > PL_stack_sp - PL_stack_base) - *(PL_stack_base + markix) = &PL_sv_undef; - else - *(PL_stack_base + markix) = *PL_stack_sp; - PL_stack_sp = PL_stack_base + markix; - } + /* Enforce some sanity in scalar context. */ + if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { + if (markix > PL_stack_sp - PL_stack_base) + *(PL_stack_base + markix) = &PL_sv_undef; + else + *(PL_stack_base + markix) = *PL_stack_sp; + PL_stack_sp = PL_stack_base + markix; } LEAVE; return NORMAL; } - - assert (0); /* Cannot get here. */ - /* This is deliberately moved here as spaghetti code to keep it out of the - hot path. */ - { - GV* autogv; - SV* sub_name; - - fooey: - /* anonymous or undef'd function leaves us no recourse */ - if (CvANON(cv) || !(gv = CvGV(cv))) - DIE(aTHX_ "Undefined subroutine called"); - - /* autoloaded stub? */ - if (cv != GvCV(gv)) { - cv = GvCV(gv); - } - /* should call AUTOLOAD now? */ - else { -try_autoload: - if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), - FALSE))) - { - cv = GvCV(autogv); - } - /* sorry */ - else { - sub_name = sv_newmortal(); - gv_efullname3(sub_name, gv, Nullch); - DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name); - } - } - if (!cv) - DIE(aTHX_ "Not a CODE reference"); - goto retry; - } } void @@ -2804,32 +2841,47 @@ Perl_sub_crush_depth(pTHX_ CV *cv) if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - SV* tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), Nullch); + SV* const tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, CvGV(cv), NULL); Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", - tmpstr); + SVfARG(tmpstr)); } } PP(pp_aelem) { - dSP; + dVAR; dSP; SV** svp; - SV* elemsv = POPs; + SV* const elemsv = POPs; IV elem = SvIV(elemsv); - AV* av = (AV*)POPs; - U32 lval = PL_op->op_flags & OPf_MOD || LVRET; - U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); + AV* const av = (AV*)POPs; + const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; + const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av)); SV *sv; if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Use of reference \"%"SVf"\" as array index", + SVfARG(elemsv)); if (elem > 0) - elem -= PL_curcop->cop_arybase; + elem -= CopARYBASE_get(PL_curcop); if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; svp = av_fetch(av, elem, lval && !defer); if (lval) { +#ifdef PERL_MALLOC_WRAP + if (SvUOK(elemsv)) { + const UV uv = SvUV(elemsv); + elem = uv > IV_MAX ? IV_MAX : uv; + } + else if (SvNOK(elemsv)) + elem = (IV)SvNV(elemsv); + if (elem > 0) { + static const char oom_array_extend[] = + "Out of memory during array extend"; /* Duplicated in av.c */ + MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); + } +#endif if (!svp || *svp == &PL_sv_undef) { SV* lv; if (!defer) @@ -2837,8 +2889,8 @@ PP(pp_aelem) lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; - sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); - LvTARG(lv) = SvREFCNT_inc(av); + sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); + LvTARG(lv) = SvREFCNT_inc_simple(av); LvTARGOFF(lv) = elem; LvTARGLEN(lv) = 1; PUSHs(lv); @@ -2859,27 +2911,26 @@ PP(pp_aelem) void Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) { - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) Perl_croak(aTHX_ PL_no_modify); if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); else if (SvTYPE(sv) >= SVt_PV) { - (void)SvOOK_off(sv); - Safefree(SvPVX(sv)); - SvLEN(sv) = SvCUR(sv) = 0; + SvPV_free(sv); + SvLEN_set(sv, 0); + SvCUR_set(sv, 0); } switch (to_what) { case OPpDEREF_SV: - SvRV(sv) = NEWSV(355,0); + SvRV_set(sv, newSV(0)); break; case OPpDEREF_AV: - SvRV(sv) = (SV*)newAV(); + SvRV_set(sv, (SV*)newAV()); break; case OPpDEREF_HV: - SvRV(sv) = (SV*)newHV(); + SvRV_set(sv, (SV*)newHV()); break; } SvROK_on(sv); @@ -2889,26 +2940,26 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { - dSP; - SV* sv = TOPs; + dVAR; dSP; + SV* const sv = TOPs; if (SvROK(sv)) { - SV* rsv = SvRV(sv); + SV* const rsv = SvRV(sv); if (SvTYPE(rsv) == SVt_PVCV) { SETs(rsv); RETURN; } } - SETs(method_common(sv, Null(U32*))); + SETs(method_common(sv, NULL)); RETURN; } PP(pp_method_named) { - dSP; - SV* sv = cSVOP_sv; - U32 hash = SvUVX(sv); + dVAR; dSP; + SV* const sv = cSVOP_sv; + U32 hash = SvSHARED_HASH(sv); XPUSHs(method_common(sv, &hash)); RETURN; @@ -2917,35 +2968,29 @@ PP(pp_method_named) STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) { - SV* sv; + dVAR; SV* ob; GV* gv; HV* stash; - char* name; STRLEN namelen; - char* packname = 0; - SV *packsv = Nullsv; + const char* packname = NULL; + SV *packsv = NULL; STRLEN packlen; - - name = SvPV(meth, namelen); - sv = *(PL_stack_base + TOPMARK + 1); + const char * const name = SvPV_const(meth, namelen); + SV * const sv = *(PL_stack_base + TOPMARK + 1); if (!sv) Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvROK(sv)) ob = (SV*)SvRV(sv); else { GV* iogv; /* this isn't a reference */ - packname = Nullch; - - if(SvOK(sv) && (packname = SvPV(sv, packlen))) { - HE* he; - he = hv_fetch_ent(PL_stashcache, sv, 0, 0); + if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) { + const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0); if (he) { stash = INT2PTR(HV*,SvIV(HeVAL(he))); goto fetch; @@ -2954,7 +2999,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) if (!SvOK(sv) || !(packname) || - !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || + !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { /* this isn't the name of a filehandle either */ @@ -2969,11 +3014,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp) : "on an undefined value"); } /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, FALSE); + stash = gv_stashpvn(packname, packlen, 0); if (!stash) packsv = sv; else { - SV* ref = newSViv(PTR2IV(stash)); + SV* const ref = newSViv(PTR2IV(stash)); hv_store(PL_stashcache, packname, packlen, ref, 0); } goto fetch; @@ -2988,6 +3033,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) && SvOBJECT(ob)))) { Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", + (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" : name); } @@ -2999,11 +3045,12 @@ S_method_common(pTHX_ SV* meth, U32* hashp) /* shortcut for simple names */ if (hashp) { - HE* he = hv_fetch_ent(stash, meth, 0, *hashp); + const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp); if (he) { gv = (GV*)HeVAL(he); if (isGV(gv) && GvCV(gv) && - (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation)) + (!GvCVGEN(gv) || GvCVGEN(gv) + == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) return (SV*)GvCV(gv); } } @@ -3018,9 +3065,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we don't want that. */ - char* leaf = name; - char* sep = Nullch; - char* p; + const char* leaf = name; + const char* sep = NULL; + const char* p; for (p = name; *p; p++) { if (*p == '\'') @@ -3029,14 +3076,30 @@ S_method_common(pTHX_ SV* meth, U32* hashp) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - /* the method name is unqualified or starts with SUPER:: */ - packname = sep ? CopSTASHPV(PL_curcop) : - stash ? HvNAME(stash) : packname; - if (!packname) + /* the method name is unqualified or starts with SUPER:: */ + bool need_strlen = 1; + if (sep) { + packname = CopSTASHPV(PL_curcop); + } + else if (stash) { + HEK * const packhek = HvNAME_HEK(stash); + if (packhek) { + packname = HEK_KEY(packhek); + packlen = HEK_LEN(packhek); + need_strlen = 0; + } else { + goto croak; + } + } + + if (!packname) { + croak: Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); - else + } + else if (need_strlen) packlen = strlen(packname); + } else { /* the method name is qualified */ @@ -3045,7 +3108,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } /* we're relying on gv_fetchmethod not autovivifying the stash */ - if (gv_stashpvn(packname, packlen, FALSE)) { + if (gv_stashpvn(packname, packlen, 0)) { Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", leaf, (int)packlen, packname); @@ -3059,3 +3122,13 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */