X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/afd9910b0da24dd1fe1207d445456a8c0f2176c5..fc15ae8fb67c31ee845fb33ce00b1c24c4c1a908:/pp.c diff --git a/pp.c b/pp.c index 401e1e3..eef2f03 100644 --- a/pp.c +++ b/pp.c @@ -1,7 +1,7 @@ /* pp.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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. @@ -47,6 +47,7 @@ extern Pid_t getpid (void); PP(pp_stub) { + dVAR; dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); @@ -57,7 +58,7 @@ PP(pp_stub) PP(pp_padav) { - dSP; dTARGET; + dVAR; dSP; dTARGET; I32 gimme; if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); @@ -78,7 +79,7 @@ PP(pp_padav) if (SvMAGICAL(TARG)) { U32 i; for (i=0; i < (U32)maxarg; i++) { - SV ** const svp = av_fetch((AV*)TARG, i, FALSE); + SV * const * const svp = av_fetch((AV*)TARG, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } @@ -98,7 +99,7 @@ PP(pp_padav) PP(pp_padhv) { - dSP; dTARGET; + dVAR; dSP; dTARGET; I32 gimme; XPUSHs(TARG); @@ -126,7 +127,7 @@ PP(pp_padhv) PP(pp_rv2gv) { - dSP; dTOPss; + dVAR; dSP; dTOPss; if (SvROK(sv)) { wasref: @@ -137,7 +138,7 @@ PP(pp_rv2gv) GV * const gv = (GV*) sv_newmortal(); gv_init(gv, 0, "", 0, 0); GvIOp(gv) = (IO *)sv; - (void)SvREFCNT_inc(sv); + SvREFCNT_inc_void_NN(sv); sv = (SV*) gv; } else if (SvTYPE(sv) != SVt_PVGV) @@ -160,18 +161,18 @@ PP(pp_rv2gv) GV *gv; if (cUNOP->op_targ) { STRLEN len; - SV *namesv = PAD_SV(cUNOP->op_targ); - const char *name = SvPV(namesv, len); - gv = (GV*)NEWSV(0,0); + SV * const namesv = PAD_SV(cUNOP->op_targ); + const char * const name = SvPV(namesv, len); + gv = (GV*)newSV(0); gv_init(gv, CopSTASH(PL_curcop), name, len, 0); } else { - const char *name = CopSTASHPV(PL_curcop); + const char * const name = CopSTASHPV(PL_curcop); gv = newGVgen(name); } if (SvTYPE(sv) < SVt_RV) sv_upgrade(sv, SVt_RV); - if (SvPVX_const(sv)) { + else if (SvPVX_const(sv)) { SvPV_free(sv); SvLEN_set(sv, 0); SvCUR_set(sv, 0); @@ -191,10 +192,10 @@ PP(pp_rv2gv) if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { - SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV); + SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV); if (!temp && (!is_gv_magical_sv(sv,0) - || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) { + || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) { RETSETUNDEF; } sv = temp; @@ -202,7 +203,14 @@ PP(pp_rv2gv) else { if (PL_op->op_private & HINT_STRICT_REFS) DIE(aTHX_ PL_no_symref_sv, sv, "a symbol"); - sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV); + if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) + == OPpDONT_INIT_GV) { + /* We are the target of a coderef assignment. Return + the scalar unchanged, and let pp_sasssign deal with + things. */ + RETURN; + } + sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV); } } } @@ -214,8 +222,8 @@ PP(pp_rv2gv) PP(pp_rv2sv) { - GV *gv = Nullgv; - dSP; dTOPss; + dVAR; dSP; dTOPss; + GV *gv = NULL; if (SvROK(sv)) { wasref: @@ -226,6 +234,8 @@ PP(pp_rv2sv) case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: DIE(aTHX_ "Not a SCALAR reference"); } } @@ -238,9 +248,14 @@ PP(pp_rv2sv) if (SvROK(sv)) goto wasref; } + if (PL_op->op_private & HINT_STRICT_REFS) { + if (SvOK(sv)) + DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR"); + else + DIE(aTHX_ PL_no_usym, "a SCALAR"); + } if (!SvOK(sv)) { - if (PL_op->op_flags & OPf_REF || - PL_op->op_private & HINT_STRICT_REFS) + if (PL_op->op_flags & OPf_REF) DIE(aTHX_ PL_no_usym, "a SCALAR"); if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); @@ -249,18 +264,16 @@ PP(pp_rv2sv) if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { - gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV); + gv = (GV*)gv_fetchsv(sv, 0, SVt_PV); if (!gv && (!is_gv_magical_sv(sv, 0) - || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV)))) + || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV)))) { RETSETUNDEF; } } else { - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR"); - gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV); + gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV); } } sv = GvSVn(gv); @@ -283,13 +296,13 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - dSP; + dVAR; dSP; AV * const av = (AV*)TOPs; SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av); if (!*sv) { - *sv = NEWSV(0,0); + *sv = newSV(0); sv_upgrade(*sv, SVt_PVMG); - sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0); + sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0); } SETs(*sv); RETURN; @@ -297,19 +310,19 @@ PP(pp_av2arylen) PP(pp_pos) { - dSP; dTARGET; dPOPss; + dVAR; dSP; dTARGET; dPOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0); + sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0); } LvTYPE(TARG) = '.'; if (LvTARG(TARG) != sv) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc(sv); + LvTARG(TARG) = SvREFCNT_inc_simple(sv); } PUSHs(TARG); /* no SvSETMAGIC */ RETURN; @@ -321,7 +334,7 @@ PP(pp_pos) I32 i = mg->mg_len; if (DO_UTF8(sv)) sv_pos_b2u(sv, &i); - PUSHi(i + PL_curcop->cop_arybase); + PUSHi(i + CopARYBASE_get(PL_curcop)); RETURN; } } @@ -331,13 +344,18 @@ PP(pp_pos) PP(pp_rv2cv) { - dSP; + dVAR; dSP; GV *gv; HV *stash; - + const I32 flags = (PL_op->op_flags & OPf_SPECIAL) + ? 0 + : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT) + ? GV_ADD|GV_NOEXPAND + : GV_ADD; /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ - CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL)); + + CV *cv = sv_2cv(TOPs, &stash, &gv, flags); if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -348,6 +366,9 @@ PP(pp_rv2cv) DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } } + else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { + cv = (CV*)gv; + } else cv = (CV*)&PL_sv_undef; SETs((SV*)cv); @@ -356,15 +377,14 @@ PP(pp_rv2cv) PP(pp_prototype) { - dSP; + dVAR; dSP; CV *cv; HV *stash; GV *gv; - SV *ret; + SV *ret = &PL_sv_undef; - ret = &PL_sv_undef; if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { - const char *s = SvPVX_const(TOPs); + const char * const s = SvPVX_const(TOPs); if (strnEQ(s, "CORE::", 6)) { const int code = keyword(s + 6, SvCUR(TOPs) - 6); if (code < 0) { /* Overridable. */ @@ -413,7 +433,7 @@ PP(pp_prototype) } } } - cv = sv_2cv(TOPs, &stash, &gv, FALSE); + cv = sv_2cv(TOPs, &stash, &gv, 0); if (cv && SvPOK(cv)) ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv))); set: @@ -423,7 +443,7 @@ PP(pp_prototype) PP(pp_anoncode) { - dSP; + dVAR; dSP; CV* cv = (CV*)PAD_SV(PL_op->op_targ); if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -434,14 +454,14 @@ PP(pp_anoncode) PP(pp_srefgen) { - dSP; + dVAR; dSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { - dSP; dMARK; + dVAR; dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; @@ -460,6 +480,7 @@ PP(pp_refgen) STATIC SV* S_refto(pTHX_ SV *sv) { + dVAR; SV* rv; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { @@ -468,19 +489,19 @@ S_refto(pTHX_ SV *sv) if (!(sv = LvTARG(sv))) sv = &PL_sv_undef; else - (void)SvREFCNT_inc(sv); + SvREFCNT_inc_void_NN(sv); } else if (SvTYPE(sv) == SVt_PVAV) { if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) av_reify((AV*)sv); SvTEMP_off(sv); - (void)SvREFCNT_inc(sv); + SvREFCNT_inc_void_NN(sv); } else if (SvPADTMP(sv) && !IS_PADGV(sv)) sv = newSVsv(sv); else { SvTEMP_off(sv); - (void)SvREFCNT_inc(sv); + SvREFCNT_inc_void_NN(sv); } rv = sv_newmortal(); sv_upgrade(rv, SVt_RV); @@ -491,7 +512,7 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - dSP; dTARGET; + dVAR; dSP; dTARGET; const char *pv; SV * const sv = POPs; @@ -508,7 +529,7 @@ PP(pp_ref) PP(pp_bless) { - dSP; + dVAR; dSP; HV *stash; if (MAXARG == 1) @@ -533,14 +554,14 @@ PP(pp_bless) PP(pp_gelem) { - dSP; + dVAR; dSP; SV *sv = POPs; const char * const elem = SvPV_nolen_const(sv); GV * const gv = (GV*)POPs; - SV * tmpRef = Nullsv; + SV * tmpRef = NULL; - sv = Nullsv; + sv = NULL; if (elem) { /* elem will always be NUL terminated. */ const char * const second_letter = elem + 1; @@ -581,13 +602,14 @@ PP(pp_gelem) break; case 'P': if (strEQ(second_letter, "ACKAGE")) { - const HEK *hek = HvNAME_HEK(GvSTASH(gv)); - sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8); + const HV * const stash = GvSTASH(gv); + const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL; + sv = hek ? newSVhek(hek) : newSVpvs("__ANON__"); } break; case 'S': if (strEQ(second_letter, "CALAR")) - tmpRef = GvSV(gv); + tmpRef = GvSVn(gv); break; } } @@ -605,7 +627,7 @@ PP(pp_gelem) PP(pp_study) { - dSP; dPOPss; + dVAR; dSP; dPOPss; register unsigned char *s; register I32 pos; register I32 ch; @@ -617,14 +639,23 @@ PP(pp_study) if (SvSCREAM(sv)) RETPUSHYES; } - else { - if (PL_lastscream) { - SvSCREAM_off(PL_lastscream); - SvREFCNT_dec(PL_lastscream); - } - PL_lastscream = SvREFCNT_inc(sv); + s = (unsigned char*)(SvPV(sv, len)); + pos = len; + if (pos <= 0 || !SvPOK(sv)) { + /* No point in studying a zero length string, and not safe to study + anything that doesn't appear to be a simple scalar (and hence might + change between now and when the regexp engine runs without our set + magic ever running) such as a reference to an object with overloaded + stringification. */ + RETPUSHNO; } + if (PL_lastscream) { + SvSCREAM_off(PL_lastscream); + SvREFCNT_dec(PL_lastscream); + } + PL_lastscream = SvREFCNT_inc_simple(sv); + s = (unsigned char*)(SvPV(sv, len)); pos = len; if (pos <= 0) @@ -662,13 +693,13 @@ PP(pp_study) SvSCREAM_on(sv); /* piggyback on m//g magic */ - sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); + sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0); RETPUSHYES; } PP(pp_trans) { - dSP; dTARG; + dVAR; dSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) @@ -688,7 +719,7 @@ PP(pp_trans) PP(pp_schop) { - dSP; dTARGET; + dVAR; dSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; @@ -696,7 +727,7 @@ PP(pp_schop) PP(pp_chop) { - dSP; dMARK; dTARGET; dORIGMARK; + dVAR; dSP; dMARK; dTARGET; dORIGMARK; while (MARK < SP) do_chop(TARG, *++MARK); SP = ORIGMARK; @@ -706,14 +737,14 @@ PP(pp_chop) PP(pp_schomp) { - dSP; dTARGET; + dVAR; dSP; dTARGET; SETi(do_chomp(TOPs)); RETURN; } PP(pp_chomp) { - dSP; dMARK; dTARGET; + dVAR; dSP; dMARK; dTARGET; register I32 count = 0; while (SP > MARK) @@ -724,7 +755,7 @@ PP(pp_chomp) PP(pp_undef) { - dSP; + dVAR; dSP; SV *sv; if (!PL_op->op_private) { @@ -751,11 +782,11 @@ PP(pp_undef) if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); - /* FALL THROUGH */ + /* FALLTHROUGH */ case SVt_PVFM: { /* let user-undef'd sub keep its identity */ - GV* gv = CvGV((CV*)sv); + GV* const gv = CvGV((CV*)sv); cv_undef((CV*)sv); CvGV((CV*)sv) = gv; } @@ -768,7 +799,7 @@ PP(pp_undef) gp_free((GV*)sv); Newxz(gp, 1, GP); GvGP(sv) = gp_ref(gp); - GvSV(sv) = NEWSV(72,0); + GvSV(sv) = newSV(0); GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = (GV*)sv; GvMULTI_on(sv); @@ -777,7 +808,7 @@ PP(pp_undef) default: if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { SvPV_free(sv); - SvPV_set(sv, Nullch); + SvPV_set(sv, NULL); SvLEN_set(sv, 0); } SvOK_off(sv); @@ -789,7 +820,7 @@ PP(pp_undef) PP(pp_predec) { - dSP; + 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) @@ -806,7 +837,7 @@ PP(pp_predec) PP(pp_postinc) { - dSP; dTARGET; + dVAR; dSP; dTARGET; if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); @@ -828,7 +859,7 @@ PP(pp_postinc) PP(pp_postdec) { - dSP; dTARGET; + dVAR; dSP; dTARGET; if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); @@ -849,7 +880,7 @@ PP(pp_postdec) PP(pp_pow) { - dSP; dATARGET; + dVAR; dSP; dATARGET; #ifdef PERL_PRESERVE_IVUV bool is_int = 0; #endif @@ -978,7 +1009,7 @@ PP(pp_pow) PP(pp_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); #ifdef PERL_PRESERVE_IVUV SvIV_please(TOPs); if (SvIOK(TOPs)) { @@ -1026,12 +1057,13 @@ PP(pp_multiply) bhigh = blow >> (4 * sizeof (UV)); blow &= botmask; if (ahigh && bhigh) { + /*EMPTY*/; /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 which is overflow. Drop to NVs below. */ } else if (!ahigh && !bhigh) { /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 so the unsigned multiply cannot overflow. */ - UV product = alow * blow; + const UV product = alow * blow; if (auvok == buvok) { /* -ve * -ve or +ve * +ve gives a +ve result. */ SP--; @@ -1096,7 +1128,7 @@ PP(pp_multiply) PP(pp_divide) { - dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN); /* Only try to do UV divide first if ((SLOPPYDIVIDE is true) or (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large @@ -1211,7 +1243,7 @@ PP(pp_divide) PP(pp_modulo) { - dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { UV left = 0; UV right = 0; @@ -1260,7 +1292,7 @@ PP(pp_modulo) if (!left_neg) { left = SvUVX(POPs); } else { - IV aiv = SvIVX(POPs); + const IV aiv = SvIVX(POPs); if (aiv >= 0) { left = aiv; left_neg = FALSE; /* effectively it's a UV now */ @@ -1339,7 +1371,7 @@ PP(pp_modulo) PP(pp_repeat) { - dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { register IV count; dPOPss; @@ -1352,7 +1384,7 @@ PP(pp_repeat) else count = uv; } else { - IV iv = SvIV(sv); + const IV iv = SvIV(sv); if (iv < 0) count = 0; else @@ -1370,12 +1402,10 @@ PP(pp_repeat) count = SvIVx(sv); if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; - I32 items = SP - MARK; - I32 max; - static const char oom_list_extend[] = - "Out of memory during list extend"; + static const char oom_list_extend[] = "Out of memory during list extend"; + const I32 items = SP - MARK; + const I32 max = items * count; - max = items * count; MEM_WRAP_CHECK_1(max, SV*, oom_list_extend); /* Did the max computation overflow? */ if (items > 0 && max > 0 && (max < items || max < count)) @@ -1421,7 +1451,7 @@ PP(pp_repeat) SP -= items; } else { /* Note: mark already snarfed by pp_list */ - SV *tmpstr = POPs; + SV * const tmpstr = POPs; STRLEN len; bool isutf; static const char oom_string_extend[] = @@ -1434,7 +1464,7 @@ PP(pp_repeat) if (count < 1) SvCUR_set(TARG, 0); else { - STRLEN max = (UV)count * len; + const STRLEN max = (UV)count * len; if (len > ((MEM_SIZE)~0)/count) Perl_croak(aTHX_ oom_string_extend); MEM_WRAP_CHECK_1(max, char, oom_string_extend); @@ -1466,7 +1496,7 @@ PP(pp_repeat) PP(pp_subtract) { - dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); + dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); useleft = USE_LEFT(TOPm1s); #ifdef PERL_PRESERVE_IVUV /* See comments in pp_add (in pp_hot.c) about Overflow, and how @@ -1583,15 +1613,15 @@ PP(pp_subtract) PP(pp_left_shift) { - dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { const IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IV i = TOPi; + const IV i = TOPi; SETi(i << shift); } else { - UV u = TOPu; + const UV u = TOPu; SETu(u << shift); } RETURN; @@ -1600,15 +1630,15 @@ PP(pp_left_shift) PP(pp_right_shift) { - dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { const IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IV i = TOPi; + const IV i = TOPi; SETi(i >> shift); } else { - UV u = TOPu; + const UV u = TOPu; SETu(u >> shift); } RETURN; @@ -1617,7 +1647,7 @@ PP(pp_right_shift) PP(pp_lt) { - dSP; tryAMAGICbinSET(lt,0); + dVAR; dSP; tryAMAGICbinSET(lt,0); #ifdef PERL_PRESERVE_IVUV SvIV_please(TOPs); if (SvIOK(TOPs)) { @@ -1684,15 +1714,22 @@ PP(pp_lt) } #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_gt) { - dSP; tryAMAGICbinSET(gt,0); + dVAR; dSP; tryAMAGICbinSET(gt,0); #ifdef PERL_PRESERVE_IVUV SvIV_please(TOPs); if (SvIOK(TOPs)) { @@ -1760,15 +1797,22 @@ PP(pp_gt) } #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_le) { - dSP; tryAMAGICbinSET(le,0); + dVAR; dSP; tryAMAGICbinSET(le,0); #ifdef PERL_PRESERVE_IVUV SvIV_please(TOPs); if (SvIOK(TOPs)) { @@ -1836,15 +1880,22 @@ PP(pp_le) } #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_ge) { - dSP; tryAMAGICbinSET(ge,0); + dVAR; dSP; tryAMAGICbinSET(ge,0); #ifdef PERL_PRESERVE_IVUV SvIV_please(TOPs); if (SvIOK(TOPs)) { @@ -1912,15 +1963,22 @@ PP(pp_ge) } #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_ne) { - dSP; tryAMAGICbinSET(ne,0); + dVAR; dSP; tryAMAGICbinSET(ne,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; @@ -1933,8 +1991,8 @@ PP(pp_ne) if (SvIOK(TOPs)) { 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 @@ -1981,19 +2039,26 @@ PP(pp_ne) } #endif { +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + dPOPTOPnnrl; + if (Perl_isnan(left) || Perl_isnan(right)) + RETSETYES; + SETs(boolSV(left != right)); +#else dPOPnv; SETs(boolSV(TOPn != value)); +#endif RETURN; } } PP(pp_ncmp) { - dSP; dTARGET; tryAMAGICbin(ncmp,0); + dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - UV right = PTR2UV(SvRV(POPs)); - UV left = PTR2UV(SvRV(TOPs)); + const UV right = PTR2UV(SvRV(POPs)); + const UV left = PTR2UV(SvRV(TOPs)); SETi((left > right) - (left < right)); RETURN; } @@ -2093,7 +2158,7 @@ PP(pp_ncmp) PP(pp_sle) { - dSP; + dVAR; dSP; int amg_type = sle_amg; int multiplier = 1; @@ -2131,7 +2196,7 @@ PP(pp_sle) PP(pp_seq) { - dSP; tryAMAGICbinSET(seq,0); + dVAR; dSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); @@ -2141,7 +2206,7 @@ PP(pp_seq) PP(pp_sne) { - dSP; tryAMAGICbinSET(sne,0); + dVAR; dSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); @@ -2151,7 +2216,7 @@ PP(pp_sne) PP(pp_scmp) { - dSP; dTARGET; tryAMAGICbin(scmp,0); + dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; const int cmp = (IN_LOCALE_RUNTIME @@ -2164,7 +2229,7 @@ PP(pp_scmp) PP(pp_bit_and) { - dSP; dATARGET; tryAMAGICbin(band,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; SvGETMAGIC(left); @@ -2187,50 +2252,32 @@ PP(pp_bit_and) } } -PP(pp_bit_xor) -{ - dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); - { - dPOPTOPssrl; - SvGETMAGIC(left); - SvGETMAGIC(right); - if (SvNIOKp(left) || SvNIOKp(right)) { - if (PL_op->op_private & HINT_INTEGER) { - const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right); - SETi(i); - } - else { - const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right); - SETu(u); - } - } - else { - do_vop(PL_op->op_type, TARG, left, right); - SETTARG; - } - RETURN; - } -} - PP(pp_bit_or) { - dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + dVAR; dSP; dATARGET; + const int op_type = PL_op->op_type; + + tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN); { dPOPTOPssrl; SvGETMAGIC(left); SvGETMAGIC(right); if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right); - SETi(i); + const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); + const IV r = SvIV_nomg(right); + const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); + SETi(result); } else { - const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right); - SETu(u); + const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); + const UV r = SvUV_nomg(right); + const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); + SETu(result); } } else { - do_vop(PL_op->op_type, TARG, left, right); + do_vop(op_type, TARG, left, right); SETTARG; } RETURN; @@ -2239,7 +2286,7 @@ PP(pp_bit_or) PP(pp_negate) { - dSP; dTARGET; tryAMAGICun(neg); + dVAR; dSP; dTARGET; tryAMAGICun(neg); { dTOPss; const int flags = SvFLAGS(sv); @@ -2273,7 +2320,7 @@ PP(pp_negate) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; - const char *s = SvPV_const(sv, len); + const char * const s = SvPV_const(sv, len); if (isIDFIRST(*s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); @@ -2309,14 +2356,14 @@ PP(pp_negate) PP(pp_not) { - dSP; tryAMAGICunSET(not); + dVAR; dSP; tryAMAGICunSET(not); *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); return NORMAL; } PP(pp_complement) { - dSP; dTARGET; tryAMAGICun(compl); + dVAR; dSP; dTARGET; tryAMAGICun(compl); { dTOPss; SvGETMAGIC(sv); @@ -2413,7 +2460,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); @@ -2423,12 +2470,19 @@ PP(pp_i_multiply) PP(pp_i_divide) { - dSP; dATARGET; tryAMAGICbin(div,opASSIGN); + IV num; + dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) - DIE(aTHX_ "Illegal division by zero"); - value = POPi / value; + DIE(aTHX_ "Illegal division by zero"); + num = POPi; + + /* avoid FPE_INTOVF on some platforms when num is IV_MIN */ + if (value == -1) + value = - num; + else + value = num / value; PUSHi( value ); RETURN; } @@ -2443,7 +2497,11 @@ PP(pp_i_modulo_0) dPOPTOPiirl; if (!right) DIE(aTHX_ "Illegal modulus zero"); - SETi( left % right ); + /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ + if (right == -1) + SETi( 0 ); + else + SETi( left % right ); RETURN; } } @@ -2455,12 +2513,16 @@ PP(pp_i_modulo_1) /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). * See below for pp_i_modulo. */ - dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) DIE(aTHX_ "Illegal modulus zero"); - SETi( left % PERL_ABS(right) ); + /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ + if (right == -1) + SETi( 0 ); + else + SETi( left % PERL_ABS(right) ); RETURN; } } @@ -2501,14 +2563,18 @@ PP(pp_i_modulo) } } #endif - SETi( left % right ); + /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ + if (right == -1) + SETi( 0 ); + else + SETi( left % right ); RETURN; } } PP(pp_i_add) { - dSP; dATARGET; tryAMAGICbin(add,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPiirl_ul; SETi( left + right ); @@ -2518,7 +2584,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPiirl_ul; SETi( left - right ); @@ -2528,7 +2594,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dSP; tryAMAGICbinSET(lt,0); + dVAR; dSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); @@ -2538,7 +2604,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - dSP; tryAMAGICbinSET(gt,0); + dVAR; dSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); @@ -2548,7 +2614,7 @@ PP(pp_i_gt) PP(pp_i_le) { - dSP; tryAMAGICbinSET(le,0); + dVAR; dSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); @@ -2558,7 +2624,7 @@ PP(pp_i_le) PP(pp_i_ge) { - dSP; tryAMAGICbinSET(ge,0); + dVAR; dSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); @@ -2568,7 +2634,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - dSP; tryAMAGICbinSET(eq,0); + dVAR; dSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); @@ -2578,7 +2644,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - dSP; tryAMAGICbinSET(ne,0); + dVAR; dSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); @@ -2588,7 +2654,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - dSP; dTARGET; tryAMAGICbin(ncmp,0); + dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; @@ -2606,7 +2672,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - dSP; dTARGET; tryAMAGICun(neg); + dVAR; dSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } @@ -2615,7 +2681,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dSP; dTARGET; tryAMAGICbin(atan2,0); + dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(Perl_atan2(left, right)); @@ -2625,20 +2691,43 @@ PP(pp_atan2) PP(pp_sin) { - dSP; dTARGET; tryAMAGICun(sin); - { - const NV value = POPn; - XPUSHn(Perl_sin(value)); - RETURN; + dVAR; dSP; dTARGET; + int amg_type = sin_amg; + const char *neg_report = NULL; + NV (*func)(NV) = Perl_sin; + const int op_type = PL_op->op_type; + + switch (op_type) { + case OP_COS: + amg_type = cos_amg; + func = Perl_cos; + break; + case OP_EXP: + amg_type = exp_amg; + func = Perl_exp; + break; + case OP_LOG: + amg_type = log_amg; + func = Perl_log; + neg_report = "log"; + break; + case OP_SQRT: + amg_type = sqrt_amg; + func = Perl_sqrt; + neg_report = "sqrt"; + break; } -} -PP(pp_cos) -{ - dSP; dTARGET; tryAMAGICun(cos); + tryAMAGICun_var(amg_type); { const NV value = POPn; - XPUSHn(Perl_cos(value)); + if (neg_report) { + if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) { + SET_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value); + } + } + XPUSHn(func(value)); RETURN; } } @@ -2660,7 +2749,7 @@ extern double drand48 (void); PP(pp_rand) { - dSP; dTARGET; + dVAR; dSP; dTARGET; NV value; if (MAXARG < 1) value = 1.0; @@ -2679,61 +2768,17 @@ PP(pp_rand) PP(pp_srand) { - dSP; - UV anum; - if (MAXARG < 1) - anum = seed(); - else - anum = POPu; + dVAR; dSP; + const UV anum = (MAXARG < 1) ? seed() : POPu; (void)seedDrand01((Rand_seed_t)anum); PL_srand_called = TRUE; EXTEND(SP, 1); RETPUSHYES; } -PP(pp_exp) -{ - dSP; dTARGET; tryAMAGICun(exp); - { - NV value; - value = POPn; - value = Perl_exp(value); - XPUSHn(value); - RETURN; - } -} - -PP(pp_log) -{ - dSP; dTARGET; tryAMAGICun(log); - { - const NV value = POPn; - if (value <= 0.0) { - SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take log of %"NVgf, value); - } - XPUSHn(Perl_log(value)); - RETURN; - } -} - -PP(pp_sqrt) -{ - dSP; dTARGET; tryAMAGICun(sqrt); - { - const NV value = POPn; - if (value < 0.0) { - SET_NUMERIC_STANDARD(); - DIE(aTHX_ "Can't take sqrt of %"NVgf, value); - } - XPUSHn(Perl_sqrt(value)); - RETURN; - } -} - PP(pp_int) { - dSP; dTARGET; tryAMAGICun(int); + dVAR; dSP; dTARGET; tryAMAGICun(int); { const IV iv = TOPi; /* attempt to convert to IV if possible. */ /* XXX it's arguable that compiler casting to IV might be subtly @@ -2772,7 +2817,7 @@ PP(pp_int) PP(pp_abs) { - dSP; dTARGET; tryAMAGICun(abs); + dVAR; dSP; dTARGET; tryAMAGICun(abs); { /* This will cache the NV value if string isn't actually integer */ const IV iv = TOPi; @@ -2807,40 +2852,9 @@ PP(pp_abs) RETURN; } - -PP(pp_hex) -{ - dSP; dTARGET; - const char *tmps; - I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; - STRLEN len; - NV result_nv; - UV result_uv; - SV* const sv = POPs; - - tmps = (SvPV_const(sv, len)); - if (DO_UTF8(sv)) { - /* If Unicode, try to downgrade - * If not possible, croak. */ - SV* const tsv = sv_2mortal(newSVsv(sv)); - - SvUTF8_on(tsv); - sv_utf8_downgrade(tsv, FALSE); - tmps = SvPV_const(tsv, len); - } - result_uv = grok_hex (tmps, &len, &flags, &result_nv); - if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { - XPUSHn(result_nv); - } - else { - XPUSHu(result_uv); - } - RETURN; -} - PP(pp_oct) { - dSP; dTARGET; + dVAR; dSP; dTARGET; const char *tmps; I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; STRLEN len; @@ -2858,12 +2872,17 @@ PP(pp_oct) sv_utf8_downgrade(tsv, FALSE); tmps = SvPV_const(tsv, len); } + if (PL_op->op_type == OP_HEX) + goto hex; + while (*tmps && len && isSPACE(*tmps)) tmps++, len--; if (*tmps == '0') tmps++, len--; - if (*tmps == 'x') + if (*tmps == 'x') { + hex: result_uv = grok_hex (tmps, &len, &flags, &result_nv); + } else if (*tmps == 'b') result_uv = grok_bin (tmps, &len, &flags, &result_nv); else @@ -2882,8 +2901,8 @@ PP(pp_oct) PP(pp_length) { - dSP; dTARGET; - SV *sv = TOPs; + dVAR; dSP; dTARGET; + SV * const sv = TOPs; if (DO_UTF8(sv)) SETi(sv_len_utf8(sv)); @@ -2894,7 +2913,7 @@ PP(pp_length) PP(pp_substr) { - dSP; dTARGET; + dVAR; dSP; dTARGET; SV *sv; I32 len = 0; STRLEN curlen; @@ -2904,9 +2923,9 @@ PP(pp_substr) I32 fail; const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; const char *tmps; - const I32 arybase = PL_curcop->cop_arybase; + const I32 arybase = CopARYBASE_get(PL_curcop); SV *repl_sv = NULL; - const char *repl = 0; + const char *repl = NULL; STRLEN repl_len; const int num_args = PL_op->op_private & 7; bool repl_need_utf8_upgrade = FALSE; @@ -3032,7 +3051,9 @@ PP(pp_substr) Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "Attempt to use reference as lvalue in substr"); } - if (SvOK(sv)) /* is it defined ? */ + if (isGV_with_GP(sv)) + SvPV_force_nolen(sv); + else if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only_UTF8(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ @@ -3040,7 +3061,7 @@ PP(pp_substr) if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0); + sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0); } else SvOK_off(TARG); @@ -3049,7 +3070,7 @@ PP(pp_substr) if (LvTARG(TARG) != sv) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc(sv); + LvTARG(TARG) = SvREFCNT_inc_simple(sv); } LvTARGOFF(TARG) = upos; LvTARGLEN(TARG) = urem; @@ -3062,7 +3083,7 @@ PP(pp_substr) PP(pp_vec) { - dSP; dTARGET; + dVAR; dSP; dTARGET; register const IV size = POPi; register const IV offset = POPi; register SV * const src = POPs; @@ -3074,13 +3095,13 @@ PP(pp_vec) TARG = sv_newmortal(); if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0); + sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0); } LvTYPE(TARG) = 'v'; if (LvTARG(TARG) != src) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc(src); + LvTARG(TARG) = SvREFCNT_inc_simple(src); } LvTARGOFF(TARG) = offset; LvTARGLEN(TARG) = size; @@ -3093,143 +3114,109 @@ PP(pp_vec) PP(pp_index) { - dSP; dTARGET; + dVAR; dSP; dTARGET; SV *big; SV *little; - SV *temp = Nullsv; + SV *temp = NULL; + STRLEN biglen; + STRLEN llen = 0; I32 offset; I32 retval; const char *tmps; const char *tmps2; - STRLEN biglen; - const I32 arybase = PL_curcop->cop_arybase; - int big_utf8; - int little_utf8; - - if (MAXARG < 3) - offset = 0; - else + const I32 arybase = CopARYBASE_get(PL_curcop); + bool big_utf8; + bool little_utf8; + const bool is_index = PL_op->op_type == OP_INDEX; + + if (MAXARG >= 3) { + /* arybase is in characters, like offset, so combine prior to the + UTF-8 to bytes calculation. */ offset = POPi - arybase; + } little = POPs; big = POPs; big_utf8 = DO_UTF8(big); little_utf8 = DO_UTF8(little); if (big_utf8 ^ little_utf8) { /* One needs to be upgraded. */ - SV * const bytes = little_utf8 ? big : little; - STRLEN len; - const char * const p = SvPV_const(bytes, len); - - temp = newSVpvn(p, len); + if (little_utf8 && !PL_encoding) { + /* Well, maybe instead we might be able to downgrade the small + string? */ + STRLEN little_len; + const U8 * const little_pv = (U8*) SvPV_const(little, little_len); + char * const pv = (char*)bytes_from_utf8(little_pv, &little_len, + &little_utf8); + if (little_utf8) { + /* If the large string is ISO-8859-1, and it's not possible to + convert the small string to ISO-8859-1, then there is no + way that it could be found anywhere by index. */ + retval = -1; + goto fail; + } - if (PL_encoding) { - sv_recode_to_utf8(temp, PL_encoding); - } else { - sv_utf8_upgrade(temp); - } - if (little_utf8) { - big = temp; - big_utf8 = TRUE; + /* At this point, pv is a malloc()ed string. So donate it to temp + to ensure it will get free()d */ + little = temp = newSV(0); + sv_usepvn(temp, pv, little_len); } else { - little = temp; - } - } - if (big_utf8 && offset > 0) - sv_pos_u2b(big, &offset, 0); - tmps = SvPV_const(big, biglen); - if (offset < 0) - offset = 0; - else if (offset > (I32)biglen) - offset = biglen; - if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, - (unsigned char*)tmps + biglen, little, 0))) - retval = -1; - else - retval = tmps2 - tmps; - if (retval > 0 && big_utf8) - sv_pos_b2u(big, &retval); - if (temp) - SvREFCNT_dec(temp); - PUSHi(retval + arybase); - RETURN; -} - -PP(pp_rindex) -{ - dSP; dTARGET; - SV *big; - SV *little; - SV *temp = Nullsv; - STRLEN blen; - STRLEN llen; - I32 offset; - I32 retval; - const char *tmps; - const char *tmps2; - const I32 arybase = PL_curcop->cop_arybase; - int big_utf8; - int little_utf8; - - if (MAXARG >= 3) - offset = POPi; - little = POPs; - big = POPs; - big_utf8 = DO_UTF8(big); - little_utf8 = DO_UTF8(little); - if (big_utf8 ^ little_utf8) { - /* One needs to be upgraded. */ - SV * const bytes = little_utf8 ? big : little; - STRLEN len; - const char *p = SvPV_const(bytes, len); + SV * const bytes = little_utf8 ? big : little; + STRLEN len; + const char * const p = SvPV_const(bytes, len); - temp = newSVpvn(p, len); + temp = newSVpvn(p, len); - if (PL_encoding) { - sv_recode_to_utf8(temp, PL_encoding); - } else { - sv_utf8_upgrade(temp); - } - if (little_utf8) { - big = temp; - big_utf8 = TRUE; - } else { - little = temp; + if (PL_encoding) { + sv_recode_to_utf8(temp, PL_encoding); + } else { + sv_utf8_upgrade(temp); + } + if (little_utf8) { + big = temp; + big_utf8 = TRUE; + } else { + little = temp; + } } } - tmps2 = SvPV_const(little, llen); - tmps = SvPV_const(big, blen); + /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */ + tmps2 = is_index ? NULL : SvPV_const(little, llen); + tmps = SvPV_const(big, biglen); if (MAXARG < 3) - offset = blen; + offset = is_index ? 0 : biglen; else { - if (offset > 0 && big_utf8) + if (big_utf8 && offset > 0) sv_pos_u2b(big, &offset, 0); - offset = offset - arybase + llen; + offset += llen; } if (offset < 0) offset = 0; - else if (offset > (I32)blen) - offset = blen; - if (!(tmps2 = rninstr(tmps, tmps + offset, - tmps2, tmps2 + llen))) + else if (offset > (I32)biglen) + offset = biglen; + if (!(tmps2 = is_index + ? fbm_instr((unsigned char*)tmps + offset, + (unsigned char*)tmps + biglen, little, 0) + : rninstr(tmps, tmps + offset, + tmps2, tmps2 + llen))) retval = -1; - else + else { retval = tmps2 - tmps; - if (retval > 0 && big_utf8) - sv_pos_b2u(big, &retval); + if (retval > 0 && big_utf8) + sv_pos_b2u(big, &retval); + } if (temp) SvREFCNT_dec(temp); + fail: PUSHi(retval + arybase); RETURN; } PP(pp_sprintf) { - dSP; dMARK; dORIGMARK; dTARGET; + dVAR; dSP; dMARK; dORIGMARK; dTARGET; do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); - if (DO_UTF8(*(MARK+1))) - SvUTF8_on(TARG); SP = ORIGMARK; PUSHTARG; RETURN; @@ -3237,7 +3224,7 @@ PP(pp_sprintf) PP(pp_ord) { - dSP; dTARGET; + dVAR; dSP; dTARGET; SV *argsv = POPs; STRLEN len; const U8 *s = (U8*)SvPV_const(argsv, len); @@ -3258,7 +3245,7 @@ PP(pp_ord) PP(pp_chr) { - dSP; dTARGET; + dVAR; dSP; dTARGET; char *tmps; UV value; @@ -3315,7 +3302,7 @@ PP(pp_chr) PP(pp_crypt) { #ifdef HAS_CRYPT - dSP; dTARGET; + dVAR; dSP; dTARGET; dPOPTOPssrl; STRLEN len; const char *tmps = SvPV_const(left, len); @@ -3363,6 +3350,7 @@ PP(pp_crypt) PP(pp_ucfirst) { + dVAR; dSP; SV *sv = TOPs; const U8 *s; @@ -3397,7 +3385,8 @@ PP(pp_ucfirst) if (slen > ulen) sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); SvUTF8_on(TARG); - SETs(TARG); + sv = TARG; + SETs(sv); } else { s = (U8*)SvPV_force_nomg(sv, slen); @@ -3431,6 +3420,7 @@ PP(pp_ucfirst) PP(pp_uc) { + dVAR; dSP; SV *sv = TOPs; STRLEN len; @@ -3448,7 +3438,8 @@ PP(pp_uc) if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); - SETs(TARG); + sv = TARG; + SETs(sv); } else { STRLEN min = len + 1; @@ -3465,7 +3456,7 @@ PP(pp_uc) if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { /* If the eventually required minimum size outgrows * the available space, we need to grow. */ - UV o = d - (U8*)SvPVX_const(TARG); + const UV o = d - (U8*)SvPVX_const(TARG); /* If someone uppercases one million U+03B0s we * SvGROW() one million times. Or we could try @@ -3481,7 +3472,8 @@ PP(pp_uc) *d = '\0'; SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); - SETs(TARG); + sv = TARG; + SETs(sv); } } else { @@ -3515,6 +3507,7 @@ PP(pp_uc) PP(pp_lc) { + dVAR; dSP; SV *sv = TOPs; STRLEN len; @@ -3532,7 +3525,8 @@ PP(pp_lc) if (!len) { SvUTF8_off(TARG); /* decontaminate */ sv_setpvn(TARG, "", 0); - SETs(TARG); + sv = TARG; + SETs(sv); } else { STRLEN min = len + 1; @@ -3548,6 +3542,7 @@ PP(pp_lc) #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */ if (uv == GREEK_CAPITAL_LETTER_SIGMA) { + /*EMPTY*/ /* * Now if the sigma is NOT followed by * /$ignorable_sequence$cased_letter/; @@ -3568,7 +3563,7 @@ PP(pp_lc) if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { /* If the eventually required minimum size outgrows * the available space, we need to grow. */ - UV o = d - (U8*)SvPVX_const(TARG); + const UV o = d - (U8*)SvPVX_const(TARG); /* If someone lowercases one million U+0130s we * SvGROW() one million times. Or we could try @@ -3584,7 +3579,8 @@ PP(pp_lc) *d = '\0'; SvUTF8_on(TARG); SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); - SETs(TARG); + sv = TARG; + SETs(sv); } } else { @@ -3619,7 +3615,7 @@ PP(pp_lc) PP(pp_quotemeta) { - dSP; dTARGET; + dVAR; dSP; dTARGET; SV * const sv = TOPs; STRLEN len; register const char *s = SvPV_const(sv,len); @@ -3672,12 +3668,12 @@ PP(pp_quotemeta) PP(pp_aslice) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; register AV* const av = (AV*)POPs; register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); if (SvTYPE(av) == SVt_PVAV) { - const I32 arybase = PL_curcop->cop_arybase; + const I32 arybase = CopARYBASE_get(PL_curcop); if (lval && PL_op->op_private & OPpLVAL_INTRO) { register SV **svp; I32 max = -1; @@ -3717,6 +3713,7 @@ PP(pp_aslice) PP(pp_each) { + dVAR; dSP; HV * const hash = (HV*)POPs; HE *entry; @@ -3748,6 +3745,7 @@ PP(pp_each) PP(pp_delete) { + dVAR; dSP; const I32 gimme = GIMME_V; const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; @@ -3807,14 +3805,15 @@ PP(pp_delete) PP(pp_exists) { + dVAR; dSP; SV *tmpsv; HV *hv; if (PL_op->op_private & OPpEXISTS_SUB) { GV *gv; - SV *sv = POPs; - CV * const cv = sv_2cv(sv, &hv, &gv, FALSE); + SV * const sv = POPs; + CV * const cv = sv_2cv(sv, &hv, &gv, 0); if (cv) RETPUSHYES; if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) @@ -3841,7 +3840,7 @@ PP(pp_exists) PP(pp_hslice) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; register HV * const hv = (HV*)POPs; register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); const bool localizing = PL_op->op_private & OPpLVAL_INTRO; @@ -3880,13 +3879,18 @@ PP(pp_hslice) DIE(aTHX_ PL_no_helem_sv, keysv); } if (localizing) { - if (preeminent) - save_helem(hv, keysv, svp); - else { - STRLEN keylen; - const char *key = SvPV_const(keysv, keylen); - SAVEDELETE(hv, savepvn(key,keylen), keylen); - } + if (HvNAME_get(hv) && isGV(*svp)) + save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); + else { + if (preeminent) + save_helem(hv, keysv, svp); + else { + STRLEN keylen; + const char * const key = SvPV_const(keysv, keylen); + SAVEDELETE(hv, savepvn(key,keylen), + SvUTF8(keysv) ? -keylen : keylen); + } + } } } *MARK = svp ? *svp : &PL_sv_undef; @@ -3903,7 +3907,7 @@ PP(pp_hslice) PP(pp_list) { - dSP; dMARK; + dVAR; dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ @@ -3916,12 +3920,13 @@ PP(pp_list) PP(pp_lslice) { + dVAR; dSP; SV ** const lastrelem = PL_stack_sp; SV ** const lastlelem = PL_stack_base + POPMARK; SV ** const firstlelem = PL_stack_base + POPMARK + 1; register SV ** const firstrelem = lastlelem + 1; - const I32 arybase = PL_curcop->cop_arybase; + const I32 arybase = CopARYBASE_get(PL_curcop); I32 is_something_there = PL_op->op_flags & OPf_MOD; register const I32 max = lastrelem - lastlelem; @@ -3969,7 +3974,7 @@ PP(pp_lslice) PP(pp_anonlist) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; const I32 items = SP - MARK; SV * const av = sv_2mortal((SV*)av_make(items, MARK+1)); SP = ORIGMARK; /* av_make() might realloc stack_sp */ @@ -3979,12 +3984,12 @@ PP(pp_anonlist) PP(pp_anonhash) { - dSP; dMARK; dORIGMARK; + dVAR; dSP; dMARK; dORIGMARK; HV* const hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { SV * const key = *++MARK; - SV * const val = NEWSV(46, 0); + SV * const val = newSV(0); if (MARK < SP) sv_setsv(val, *++MARK); else if (ckWARN(WARN_MISC)) @@ -4008,7 +4013,7 @@ PP(pp_splice) I32 newlen; I32 after; I32 diff; - SV **tmparyval = 0; + SV **tmparyval = NULL; const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied); if (mg) { @@ -4029,7 +4034,7 @@ PP(pp_splice) if (offset < 0) offset += AvFILLp(ary) + 1; else - offset -= PL_curcop->cop_arybase; + offset -= CopARYBASE_get(PL_curcop); if (offset < 0) DIE(aTHX_ PL_no_aelem, i); if (++MARK < SP) { @@ -4222,7 +4227,7 @@ PP(pp_push) } else { for (++MARK; MARK <= SP; MARK++) { - SV * const sv = NEWSV(51, 0); + SV * const sv = newSV(0); if (*MARK) sv_setsv(sv, *MARK); av_store(ary, AvFILLp(ary)+1, sv); @@ -4233,25 +4238,14 @@ PP(pp_push) RETURN; } -PP(pp_pop) -{ - dSP; - AV * const av = (AV*)POPs; - SV * const sv = av_pop(av); - if (AvREAL(av)) - (void)sv_2mortal(sv); - PUSHs(sv); - RETURN; -} - PP(pp_shift) { + dVAR; dSP; AV * const av = (AV*)POPs; - SV * const sv = av_shift(av); + SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); EXTEND(SP, 1); - if (!sv) - RETPUSHUNDEF; + assert (sv); if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); @@ -4288,7 +4282,7 @@ PP(pp_unshift) PP(pp_reverse) { - dSP; dMARK; + dVAR; dSP; dMARK; SV ** const oldsp = SP; if (GIMME == G_ARRAY) { @@ -4316,7 +4310,8 @@ PP(pp_reverse) sv_setsv(TARG, (SP > MARK) ? *SP : (padoff_du = find_rundefsvoffset(), - (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR) + (padoff_du == NOT_IN_PAD + || PAD_COMPNAME_FLAGS_isOUR(padoff_du)) ? DEFSV : PAD_SVl(padoff_du))); up = SvPV_force(TARG, len); if (len > 1) { @@ -4383,7 +4378,7 @@ PP(pp_split) const I32 oldsave = PL_savestack_ix; I32 make_mortal = 1; bool multiline = 0; - MAGIC *mg = (MAGIC *) NULL; + MAGIC *mg = NULL; #ifdef DEBUGGING Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); @@ -4409,7 +4404,7 @@ PP(pp_split) else if (gimme != G_ARRAY) ary = GvAVn(PL_defgv); else - ary = Nullav; + ary = NULL; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { realarray = 1; PUTBACK; @@ -4662,6 +4657,7 @@ PP(pp_split) PP(pp_lock) { + dVAR; dSP; dTOPss; SV *retsv = sv; @@ -4677,6 +4673,7 @@ PP(pp_lock) PP(unimplemented_op) { + dVAR; DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op), PL_op->op_type); }