X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0157ef98f2758c1571b03548125e2b193caff16d..7a11f5c382a3ea35768e2f50d7dbeaed6adc2398:/pp.c?ds=sidebyside diff --git a/pp.c b/pp.c index ed6fd5f..ea05bb4 100644 --- a/pp.c +++ b/pp.c @@ -47,11 +47,13 @@ extern Pid_t getpid (void); _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_; #endif +static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1; +static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1; + /* variations on pp_null */ PP(pp_stub) { - dVAR; dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); @@ -62,11 +64,11 @@ PP(pp_stub) PP(pp_padav) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVAV); - if (PL_op->op_private & OPpLVAL_INTRO) - if (!(PL_op->op_private & OPpPAD_STATE)) + if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) + if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { @@ -85,23 +87,27 @@ PP(pp_padav) gimme = GIMME_V; if (gimme == G_ARRAY) { /* XXX see also S_pushav in pp_hot.c */ - const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; + const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { - U32 i; - for (i=0; i < (U32)maxarg; i++) { + Size_t i; + for (i=0; i < maxarg; i++) { SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { - Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*); + PADOFFSET i; + for (i=0; i < (PADOFFSET)maxarg; i++) { + SV * const sv = AvARRAY((const AV *)TARG)[i]; + SP[i+1] = sv ? sv : &PL_sv_undef; + } } SP += maxarg; } else if (gimme == G_SCALAR) { SV* const sv = sv_newmortal(); - const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; + const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; sv_setiv(sv, maxarg); PUSHs(sv); } @@ -110,13 +116,13 @@ PP(pp_padav) PP(pp_padhv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVHV); XPUSHs(TARG); - if (PL_op->op_private & OPpLVAL_INTRO) - if (!(PL_op->op_private & OPpPAD_STATE)) + if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) + if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); if (PL_op->op_flags & OPf_REF) RETURN; @@ -147,7 +153,7 @@ PP(pp_padhv) PP(pp_padcv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; assert(SvTYPE(TARG) == SVt_PVCV); XPUSHs(TARG); RETURN; @@ -155,14 +161,14 @@ PP(pp_padcv) PP(pp_introcv) { - dVAR; dTARGET; + dTARGET; SvPADSTALE_off(TARG); return NORMAL; } PP(pp_clonecv) { - dVAR; dTARGET; + dTARGET; MAGIC * const mg = mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG], PERL_MAGIC_proto); @@ -204,7 +210,6 @@ static SV * S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, const bool noinit) { - dVAR; if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv); if (SvROK(sv)) { if (SvAMAGIC(sv)) { @@ -219,8 +224,9 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, SvREFCNT_inc_void_NN(sv); sv = MUTABLE_SV(gv); } - else if (!isGV_with_GP(sv)) - return (SV *)Perl_die(aTHX_ "Not a GLOB reference"); + else if (!isGV_with_GP(sv)) { + Perl_die(aTHX_ "Not a GLOB reference"); + } } else { if (!isGV_with_GP(sv)) { @@ -234,13 +240,16 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, Perl_croak_no_modify(); if (cUNOP->op_targ) { SV * const namesv = PAD_SV(cUNOP->op_targ); + HV *stash = CopSTASH(PL_curcop); + if (SvTYPE(stash) != SVt_PVHV) stash = NULL; gv = MUTABLE_GV(newSV(0)); - gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0); + gv_init_sv(gv, stash, namesv, 0); } else { const char * const name = CopSTASHPV(PL_curcop); gv = newGVgen_flags(name, HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 ); + SvREFCNT_inc_simple_void_NN(gv); } prepare_SV_for_RV(sv); SvRV_set(sv, MUTABLE_SV(gv)); @@ -248,8 +257,9 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, SvSETMAGIC(sv); goto wasref; } - if (PL_op->op_flags & OPf_REF || strict) - return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol"); + if (PL_op->op_flags & OPf_REF || strict) { + Perl_die(aTHX_ PL_no_usym, "a symbol"); + } if (ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); return &PL_sv_undef; @@ -262,14 +272,14 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, return &PL_sv_undef; } else { - if (strict) - return - (SV *)Perl_die(aTHX_ - S_no_symref_sv, - sv, - (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), - "a symbol" - ); + if (strict) { + Perl_die(aTHX_ + S_no_symref_sv, + sv, + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), + "a symbol" + ); + } if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) == OPpDONT_INIT_GV) { /* We are the target of a coderef assignment. Return @@ -294,7 +304,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, PP(pp_rv2gv) { - dVAR; dSP; dTOPss; + dSP; dTOPss; sv = S_rv2gv(aTHX_ sv, PL_op->op_private & OPpDEREF, @@ -313,7 +323,6 @@ GV * Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const svtype type, SV ***spp) { - dVAR; GV *gv; PERL_ARGS_ASSERT_SOFTREF2XV; @@ -356,7 +365,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, PP(pp_rv2sv) { - dVAR; dSP; dTOPss; + dSP; dTOPss; GV *gv = NULL; SvGETMAGIC(sv); @@ -404,7 +413,7 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - dVAR; dSP; + dSP; AV * const av = MUTABLE_AV(TOPs); const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; if (lvalue) { @@ -422,7 +431,7 @@ PP(pp_av2arylen) PP(pp_pos) { - dVAR; dSP; dPOPss; + dSP; dPOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ @@ -433,24 +442,22 @@ PP(pp_pos) RETURN; } else { - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg && mg->mg_len >= 0) { + const MAGIC * const mg = mg_find_mglob(sv); + if (mg && mg->mg_len != -1) { dTARGET; - I32 i = mg->mg_len; - if (DO_UTF8(sv)) - sv_pos_b2u(sv, &i); - PUSHi(i); + STRLEN i = mg->mg_len; + if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv)) + i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN); + PUSHu(i); RETURN; } - } - RETPUSHUNDEF; + RETPUSHUNDEF; } } PP(pp_rv2cv) { - dVAR; dSP; + dSP; GV *gv; HV *stash_unused; const I32 flags = (PL_op->op_flags & OPf_SPECIAL) @@ -465,7 +472,9 @@ PP(pp_rv2cv) CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags); if (cv) NOOP; else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { - cv = MUTABLE_CV(gv); + cv = SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : MUTABLE_CV(gv); } else cv = MUTABLE_CV(&PL_sv_undef); @@ -475,7 +484,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - dVAR; dSP; + dSP; CV *cv; HV *stash; GV *gv; @@ -486,12 +495,9 @@ PP(pp_prototype) const char * s = SvPVX_const(TOPs); if (strnEQ(s, "CORE::", 6)) { const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1); - if (!code || code == -KEY_CORE) - DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"", - SVfARG(newSVpvn_flags( - s+6, SvCUR(TOPs)-6, - (SvFLAGS(TOPs) & SVf_UTF8)|SVs_TEMP - ))); + if (!code) + DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"", + UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6)); { SV * const sv = core_prototype(NULL, s + 6, code, NULL); if (sv) ret = sv; @@ -511,7 +517,7 @@ PP(pp_prototype) PP(pp_anoncode) { - dVAR; dSP; + dSP; CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ)); if (CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); @@ -522,14 +528,14 @@ PP(pp_anoncode) PP(pp_srefgen) { - dVAR; dSP; + dSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { - dVAR; dSP; dMARK; + dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; @@ -548,7 +554,6 @@ PP(pp_refgen) STATIC SV* S_refto(pTHX_ SV *sv) { - dVAR; SV* rv; PERL_ARGS_ASSERT_REFTO; @@ -567,8 +572,10 @@ S_refto(pTHX_ SV *sv) SvTEMP_off(sv); SvREFCNT_inc_void_NN(sv); } - else if (SvPADTMP(sv) && !IS_PADGV(sv)) + else if (SvPADTMP(sv)) { + assert(!IS_PADGV(sv)); sv = newSVsv(sv); + } else { SvTEMP_off(sv); SvREFCNT_inc_void_NN(sv); @@ -582,37 +589,54 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - dVAR; dSP; dTARGET; - SV * const sv = POPs; - - if (sv) - SvGETMAGIC(sv); + dSP; + SV * const sv = TOPs; - if (!sv || !SvROK(sv)) - RETPUSHNO; + SvGETMAGIC(sv); + if (!SvROK(sv)) + SETs(&PL_sv_no); + else { + dTARGET; + SETs(TARG); + /* use the return value that is in a register, its the same as TARG */ + TARG = sv_ref(TARG,SvRV(sv),TRUE); + SvSETMAGIC(TARG); + } - (void)sv_ref(TARG,SvRV(sv),TRUE); - PUSHTARG; - RETURN; + return NORMAL; } PP(pp_bless) { - dVAR; dSP; + dSP; HV *stash; if (MAXARG == 1) + { curstash: stash = CopSTASH(PL_curcop); + if (SvTYPE(stash) != SVt_PVHV) + Perl_croak(aTHX_ "Attempt to bless into a freed package"); + } else { SV * const ssv = POPs; STRLEN len; const char *ptr; if (!ssv) goto curstash; - if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) + SvGETMAGIC(ssv); + if (SvROK(ssv)) { + if (!SvAMAGIC(ssv)) { + frog: Perl_croak(aTHX_ "Attempt to bless into a reference"); - ptr = SvPV_const(ssv,len); + } + /* SvAMAGIC is on here, but it only means potentially overloaded, + so after stringification: */ + ptr = SvPV_nomg_const(ssv,len); + /* We need to check the flag again: */ + if (!SvAMAGIC(ssv)) goto frog; + } + else ptr = SvPV_nomg_const(ssv,len); if (len == 0) Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Explicit blessing to '' (assuming package main)"); @@ -625,7 +649,7 @@ PP(pp_bless) PP(pp_gelem) { - dVAR; dSP; + dSP; SV *sv = POPs; STRLEN len; @@ -704,7 +728,7 @@ PP(pp_gelem) PP(pp_study) { - dVAR; dSP; dPOPss; + dSP; dPOPss; STRLEN len; (void)SvPV(sv, len); @@ -720,7 +744,7 @@ PP(pp_study) PP(pp_trans) { - dVAR; dSP; dTARG; + dSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) @@ -750,7 +774,6 @@ PP(pp_trans) static void S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) { - dVAR; STRLEN len; char *s; @@ -914,7 +937,7 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) PP(pp_schop) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const bool chomping = PL_op->op_type == OP_SCHOMP; if (chomping) @@ -926,7 +949,7 @@ PP(pp_schop) PP(pp_chop) { - dVAR; dSP; dMARK; dTARGET; dORIGMARK; + dSP; dMARK; dTARGET; dORIGMARK; const bool chomping = PL_op->op_type == OP_CHOMP; if (chomping) @@ -940,7 +963,7 @@ PP(pp_chop) PP(pp_undef) { - dVAR; dSP; + dSP; SV *sv; if (!PL_op->op_private) { @@ -952,7 +975,8 @@ PP(pp_undef) if (!sv) RETPUSHUNDEF; - SV_CHECK_THINKFIRST_COW_DROP(sv); + if (SvTHINKFIRST(sv)) + sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); switch (SvTYPE(sv)) { case SVt_NULL: @@ -969,7 +993,12 @@ PP(pp_undef) "Constant subroutine %"SVf" undefined", SVfARG(CvANON((const CV *)sv) ? newSVpvs_flags("(anonymous)", SVs_TEMP) - : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv)))))); + : sv_2mortal(newSVhek( + CvNAMED(sv) + ? CvNAME_HEK((CV *)sv) + : GvENAME_HEK(CvGV((const CV *)sv)) + )) + )); /* FALLTHROUGH */ case SVt_PVFM: { @@ -1003,10 +1032,13 @@ PP(pp_undef) else stash = NULL; } + SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); gp_free(MUTABLE_GV(sv)); Newxz(gp, 1, GP); GvGP_set(sv, gp_ref(gp)); +#ifndef PERL_DONT_CREATE_GVSV GvSV(sv) = newSV(0); +#endif GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = MUTABLE_GV(sv); GvMULTI_on(sv); @@ -1041,7 +1073,7 @@ PP(pp_undef) PP(pp_postinc) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const bool inc = PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) @@ -1070,7 +1102,7 @@ PP(pp_postinc) PP(pp_pow) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; #ifdef PERL_PRESERVE_IVUV bool is_int = 0; #endif @@ -1237,7 +1269,7 @@ PP(pp_pow) PP(pp_multiply) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1359,7 +1391,7 @@ PP(pp_multiply) PP(pp_divide) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1479,7 +1511,7 @@ PP(pp_divide) PP(pp_modulo) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric); { UV left = 0; @@ -1606,7 +1638,7 @@ PP(pp_modulo) PP(pp_repeat) { - dVAR; dSP; dATARGET; + dSP; dATARGET; IV count; SV *sv; @@ -1628,28 +1660,31 @@ PP(pp_repeat) else count = uv; } else { - const IV iv = SvIV_nomg(sv); - if (iv < 0) - count = 0; - else - count = iv; + count = SvIV_nomg(sv); } } else if (SvNOKp(sv)) { const NV nv = SvNV_nomg(sv); if (nv < 0.0) - count = 0; + count = -1; /* An arbitrary negative integer */ else count = (IV)nv; } else count = SvIV_nomg(sv); + if (count < 0) { + count = 0; + Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), + "Negative repeat count does nothing"); + } + if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; static const char* const oom_list_extend = "Out of memory during list extend"; const I32 items = SP - MARK; const I32 max = items * count; + const U8 mod = PL_op->op_flags & OPf_MOD; MEM_WRAP_CHECK_1(max, SV*, oom_list_extend); /* Did the max computation overflow? */ @@ -1682,8 +1717,13 @@ PP(pp_repeat) SvREADONLY_on(*SP); } #else - if (*SP) + if (*SP) { + if (mod && SvPADTMP(*SP)) { + assert(!IS_PADGV(*SP)); + *SP = sv_mortalcopy(*SP); + } SvTEMP_off((*SP)); + } #endif SP--; } @@ -1741,7 +1781,7 @@ PP(pp_repeat) PP(pp_subtract) { - dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr; + dSP; dATARGET; bool useleft; SV *svl, *svr; tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1860,7 +1900,7 @@ PP(pp_subtract) PP(pp_left_shift) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric); svr = POPs; svl = TOPs; @@ -1880,7 +1920,7 @@ PP(pp_left_shift) PP(pp_right_shift) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric); svr = POPs; svl = TOPs; @@ -1900,7 +1940,7 @@ PP(pp_right_shift) PP(pp_lt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric); @@ -1916,7 +1956,7 @@ PP(pp_lt) PP(pp_gt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric); @@ -1932,7 +1972,7 @@ PP(pp_gt) PP(pp_le) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric); @@ -1948,7 +1988,7 @@ PP(pp_le) PP(pp_ge) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric); @@ -1964,7 +2004,7 @@ PP(pp_ge) PP(pp_ne) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric); @@ -1987,8 +2027,6 @@ PP(pp_ne) I32 Perl_do_ncmp(pTHX_ SV* const left, SV * const right) { - dVAR; - PERL_ARGS_ASSERT_DO_NCMP; #ifdef PERL_PRESERVE_IVUV /* Fortunately it seems NaN isn't IOK */ @@ -2054,7 +2092,7 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) PP(pp_ncmp) { - dVAR; dSP; + dSP; SV *left, *right; I32 value; tryAMAGICbin_MG(ncmp_amg, AMGf_numeric); @@ -2073,7 +2111,7 @@ PP(pp_ncmp) PP(pp_sle) { - dVAR; dSP; + dSP; int amg_type = sle_amg; int multiplier = 1; @@ -2101,9 +2139,13 @@ PP(pp_sle) tryAMAGICbin_MG(amg_type, AMGf_set); { dPOPTOPssrl; - const int cmp = (IN_LOCALE_RUNTIME - ? sv_cmp_locale_flags(left, right, 0) - : sv_cmp_flags(left, right, 0)); + const int cmp = +#ifdef USE_LOCALE_COLLATE + (IN_LC_RUNTIME(LC_COLLATE)) + ? sv_cmp_locale_flags(left, right, 0) + : +#endif + sv_cmp_flags(left, right, 0); SETs(boolSV(cmp * multiplier < rhs)); RETURN; } @@ -2111,7 +2153,7 @@ PP(pp_sle) PP(pp_seq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(seq_amg, AMGf_set); { dPOPTOPssrl; @@ -2122,7 +2164,7 @@ PP(pp_seq) PP(pp_sne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(sne_amg, AMGf_set); { dPOPTOPssrl; @@ -2133,13 +2175,17 @@ PP(pp_sne) PP(pp_scmp) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(scmp_amg, 0); { dPOPTOPssrl; - const int cmp = (IN_LOCALE_RUNTIME - ? sv_cmp_locale_flags(left, right, 0) - : sv_cmp_flags(left, right, 0)); + const int cmp = +#ifdef USE_LOCALE_COLLATE + (IN_LC_RUNTIME(LC_COLLATE)) + ? sv_cmp_locale_flags(left, right, 0) + : +#endif + sv_cmp_flags(left, right, 0); SETi( cmp ); RETURN; } @@ -2147,7 +2193,7 @@ PP(pp_scmp) PP(pp_bit_and) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(band_amg, AMGf_assign); { dPOPTOPssrl; @@ -2175,7 +2221,7 @@ PP(pp_bit_and) PP(pp_bit_or) { - dVAR; dSP; dATARGET; + dSP; dATARGET; const int op_type = PL_op->op_type; tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign); @@ -2232,7 +2278,7 @@ S_negate_string(pTHX) PP(pp_negate) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(neg_amg, AMGf_numeric); if (S_negate_string(aTHX)) return NORMAL; { @@ -2276,7 +2322,7 @@ PP(pp_negate) PP(pp_not) { - dVAR; dSP; + dSP; tryAMAGICun_MG(not_amg, AMGf_set); *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp)); return NORMAL; @@ -2284,7 +2330,7 @@ PP(pp_not) PP(pp_complement) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(compl_amg, AMGf_numeric); { dTOPss; @@ -2303,9 +2349,8 @@ PP(pp_complement) I32 anum; STRLEN len; - (void)SvPV_nomg_const(sv,len); /* force check for uninit var */ - sv_setsv_nomg(TARG, sv); - tmps = (U8*)SvPV_force_nomg(TARG, len); + sv_copypv_nomg(TARG, sv); + tmps = (U8*)SvPV_nomg(TARG, len); anum = len; if (SvUTF8(TARG)) { /* Calculate exact length, let's not estimate. */ @@ -2386,7 +2431,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(mult_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2398,7 +2443,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { IV num; - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(div_amg, AMGf_assign); { dPOPTOPssrl; @@ -2425,7 +2470,7 @@ PP(pp_i_modulo) #endif { /* This is the vanilla old i_modulo. */ - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2448,7 +2493,7 @@ 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; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2509,7 +2554,7 @@ PP(pp_i_modulo) PP(pp_i_add) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(add_amg, AMGf_assign); { dPOPTOPiirl_ul_nomg; @@ -2520,7 +2565,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(subtr_amg, AMGf_assign); { dPOPTOPiirl_ul_nomg; @@ -2531,7 +2576,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(lt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2542,7 +2587,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(gt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2553,7 +2598,7 @@ PP(pp_i_gt) PP(pp_i_le) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(le_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2564,7 +2609,7 @@ PP(pp_i_le) PP(pp_i_ge) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ge_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2575,7 +2620,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(eq_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2586,7 +2631,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ne_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2597,7 +2642,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(ncmp_amg, 0); { dPOPTOPiirl_nomg; @@ -2616,7 +2661,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(neg_amg, 0); if (S_negate_string(aTHX)) return NORMAL; { @@ -2631,7 +2676,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(atan2_amg, 0); { dPOPTOPnnrl_nomg; @@ -2642,46 +2687,42 @@ PP(pp_atan2) PP(pp_sin) { - dVAR; dSP; dTARGET; - int amg_type = sin_amg; + dSP; dTARGET; + int amg_type = fallback_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; + case OP_SIN: amg_type = sin_amg; break; + case OP_COS: amg_type = cos_amg; break; + case OP_EXP: amg_type = exp_amg; break; + case OP_LOG: amg_type = log_amg; neg_report = "log"; break; + case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break; } + assert(amg_type != fallback_amg); tryAMAGICun_MG(amg_type, 0); { SV * const arg = POPs; const NV value = SvNV_nomg(arg); - if (neg_report) { + NV result = NV_NAN; + if (neg_report) { /* log or sqrt */ if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) { SET_NUMERIC_STANDARD(); /* diag_listed_as: Can't take log of %g */ DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value); } } - XPUSHn(func(value)); + switch (op_type) { + default: + case OP_SIN: result = Perl_sin(value); break; + case OP_COS: result = Perl_cos(value); break; + case OP_EXP: result = Perl_exp(value); break; + case OP_LOG: result = Perl_log(value); break; + case OP_SQRT: result = Perl_sqrt(value); break; + } + XPUSHn(result); RETURN; } } @@ -2697,13 +2738,8 @@ PP(pp_sin) --Jarkko Hietaniemi 27 September 1998 */ -#ifndef HAS_DRAND48_PROTO -extern double drand48 (void); -#endif - PP(pp_rand) { - dVAR; if (!PL_srand_called) { (void)seedDrand01((Rand_seed_t)seed()); PL_srand_called = TRUE; @@ -2738,7 +2774,7 @@ PP(pp_rand) PP(pp_srand) { - dVAR; dSP; dTARGET; + dSP; dTARGET; UV anum; if (MAXARG >= 1 && (TOPs || POPs)) { @@ -2776,7 +2812,7 @@ PP(pp_srand) PP(pp_int) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(int_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2818,7 +2854,7 @@ PP(pp_int) PP(pp_abs) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(abs_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2858,7 +2894,7 @@ PP(pp_abs) PP(pp_oct) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps; I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; STRLEN len; @@ -2883,11 +2919,11 @@ PP(pp_oct) tmps++, len--; if (*tmps == '0') tmps++, len--; - if (*tmps == 'x' || *tmps == 'X') { + if (isALPHA_FOLD_EQ(*tmps, 'x')) { hex: result_uv = grok_hex (tmps, &len, &flags, &result_nv); } - else if (*tmps == 'b' || *tmps == 'B') + else if (isALPHA_FOLD_EQ(*tmps, 'b')) result_uv = grok_bin (tmps, &len, &flags, &result_nv); else result_uv = grok_oct (tmps, &len, &flags, &result_nv); @@ -2905,7 +2941,7 @@ PP(pp_oct) PP(pp_length) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; SvGETMAGIC(sv); @@ -2933,10 +2969,10 @@ PP(pp_length) always be true for an explicit 0. */ bool -Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, - bool pos1_is_uv, IV len_iv, - bool len_is_uv, STRLEN *posp, - STRLEN *lenp) +Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, + bool pos1_is_uv, IV len_iv, + bool len_is_uv, STRLEN *posp, + STRLEN *lenp) { IV pos2_iv; int pos2_is_uv; @@ -2997,7 +3033,7 @@ Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, PP(pp_substr) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *sv; STRLEN curlen; STRLEN utf8_curlen; @@ -3136,7 +3172,7 @@ bound_fail: PP(pp_vec) { - dVAR; dSP; + dSP; const IV size = POPi; const IV offset = POPi; SV * const src = POPs; @@ -3164,14 +3200,14 @@ PP(pp_vec) PP(pp_index) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *big; SV *little; SV *temp = NULL; STRLEN biglen; STRLEN llen = 0; - I32 offset; - I32 retval; + SSize_t offset = 0; + SSize_t retval; const char *big_p; const char *little_p; bool big_utf8; @@ -3254,13 +3290,13 @@ PP(pp_index) offset = is_index ? 0 : biglen; else { if (big_utf8 && offset > 0) - sv_pos_u2b(big, &offset, 0); + offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN); if (!is_index) offset += llen; } if (offset < 0) offset = 0; - else if (offset > (I32)biglen) + else if (offset > (SSize_t)biglen) offset = biglen; if (!(little_p = is_index ? fbm_instr((unsigned char*)big_p + offset, @@ -3271,7 +3307,7 @@ PP(pp_index) else { retval = little_p - big_p; if (retval > 0 && big_utf8) - sv_pos_b2u(big, &retval); + retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); } SvREFCNT_dec(temp); fail: @@ -3281,7 +3317,7 @@ PP(pp_index) PP(pp_sprintf) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SvTAINTED_off(TARG); do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); @@ -3292,7 +3328,7 @@ PP(pp_sprintf) PP(pp_ord) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *argsv = POPs; STRLEN len; @@ -3301,41 +3337,51 @@ PP(pp_ord) if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { SV * const tmpsv = sv_2mortal(newSVsv(argsv)); s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding); + len = UTF8SKIP(s); /* Should be well-formed; so this is its length */ argsv = tmpsv; } - XPUSHu(DO_UTF8(argsv) ? - utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) : - (UV)(*s & 0xff)); + XPUSHu(DO_UTF8(argsv) + ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) + : (UV)(*s)); RETURN; } PP(pp_chr) { - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; UV value; SV *top = POPs; SvGETMAGIC(top); - if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ - && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) - || - ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) - && SvNV_nomg(top) < 0.0))) { + if (SvNOK(top) && Perl_isinfnan(SvNV(top))) { + if (ckWARN(WARN_UTF8)) { + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "Invalid number (%"NVgf") in chr", SvNV(top)); + } + value = UNICODE_REPLACEMENT; + } + else { + if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ + && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) + || + ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) + && SvNV_nomg(top) < 0.0))) { if (ckWARN(WARN_UTF8)) { if (SvGMAGICAL(top)) { SV *top2 = sv_newmortal(); sv_setsv_nomg(top2, top); top = top2; } - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "Invalid negative number (%"SVf") in chr", top); - } - value = UNICODE_REPLACEMENT; - } else { - value = SvUV_nomg(top); + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "Invalid negative number (%"SVf") in chr", SVfARG(top)); + } + value = UNICODE_REPLACEMENT; + } else { + value = SvUV_nomg(top); + } } SvUPGRADE(TARG,SVt_PV); @@ -3381,7 +3427,7 @@ PP(pp_chr) PP(pp_crypt) { #ifdef HAS_CRYPT - dVAR; dSP; dTARGET; + dSP; dTARGET; dPOPTOPssrl; STRLEN len; const char *tmps = SvPV_const(left, len); @@ -3430,15 +3476,6 @@ PP(pp_crypt) /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */ -/* Generates code to store a unicode codepoint c that is known to occupy - * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1, - * and p is advanced to point to the next available byte after the two bytes */ -#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \ - STMT_START { \ - *(p)++ = UTF8_TWO_BYTE_HI(c); \ - *((p)++) = UTF8_TWO_BYTE_LO(c); \ - } STMT_END - PP(pp_ucfirst) { /* Actually is both lcfirst() and ucfirst(). Only the first character @@ -3446,7 +3483,6 @@ PP(pp_ucfirst) * take the source and change that one character and store it back, but not * if read-only etc, or if the length changes */ - dVAR; dSP; SV *source = TOPs; STRLEN slen; /* slen is the byte length of the whole SV. */ @@ -3464,22 +3500,16 @@ PP(pp_ucfirst) STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or * lowercased) character stored in tmpbuf. May be either * UTF-8 or not, but in either case is the number of bytes */ - bool tainted = FALSE; - SvGETMAGIC(source); - if (SvOK(source)) { - s = (const U8*)SvPV_nomg_const(source, slen); - } else { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(source); - s = (const U8*)""; - slen = 0; - } + s = (const U8*)SvPV_const(source, slen); /* We may be able to get away with changing only the first character, in * place, but not if read-only, etc. Later we may discover more reasons to * not convert in-place. */ - inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source); + inplace = !SvREADONLY(source) + && ( SvPADTMP(source) + || ( SvTEMP(source) && !SvSMAGICAL(source) + && SvREFCNT(source) == 1)); /* First calculate what the changed first character should be. This affects * whether we can just swap it out, leaving the rest of the string unchanged, @@ -3493,12 +3523,18 @@ PP(pp_ucfirst) doing_utf8 = TRUE; ulen = UTF8SKIP(s); if (op_type == OP_UCFIRST) { - _to_utf8_title_flags(s, tmpbuf, &tculen, - cBOOL(IN_LOCALE_RUNTIME), &tainted); +#ifdef USE_LOCALE_CTYPE + _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); +#else + _to_utf8_title_flags(s, tmpbuf, &tculen, 0); +#endif } else { - _to_utf8_lower_flags(s, tmpbuf, &tculen, - cBOOL(IN_LOCALE_RUNTIME), &tainted); +#ifdef USE_LOCALE_CTYPE + _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE)); +#else + _to_utf8_lower_flags(s, tmpbuf, &tculen, 0); +#endif } /* we can't do in-place if the length changes. */ @@ -3516,22 +3552,42 @@ PP(pp_ucfirst) if (op_type == OP_LCFIRST) { /* lower case the first letter: no trickiness for any character */ - *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) : - ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s)); + *tmpbuf = +#ifdef USE_LOCALE_CTYPE + (IN_LC_RUNTIME(LC_CTYPE)) + ? toLOWER_LC(*s) + : +#endif + (IN_UNI_8_BIT) + ? toLOWER_LATIN1(*s) + : toLOWER(*s); } /* is ucfirst() */ - else if (IN_LOCALE_RUNTIME) { - *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales - * have upper and title case different - */ +#ifdef USE_LOCALE_CTYPE + else if (IN_LC_RUNTIME(LC_CTYPE)) { + if (IN_UTF8_CTYPE_LOCALE) { + goto do_uni_rules; + } + + *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any + locales have upper and title case + different */ } +#endif else if (! IN_UNI_8_BIT) { *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or * on EBCDIC machines whatever the * native function does */ } - else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */ - UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's'); + else { + /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is + * UTF-8, which we treat as not in locale), and cased latin1 */ + UV title_ord; +#ifdef USE_LOCALE_CTYPE + do_uni_rules: +#endif + + title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's'); if (tculen > 1) { assert(tculen == 2); @@ -3632,17 +3688,9 @@ PP(pp_ucfirst) SvCUR_set(dest, need - 1); } - if (tainted) { - TAINT; - SvTAINTED_on(dest); - } } else { /* Neither source nor dest are in or need to be UTF-8 */ if (slen) { - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(dest); - } if (inplace) { /* in-place, only need to change the 1st char */ *d = *tmpbuf; } @@ -3661,7 +3709,7 @@ PP(pp_ucfirst) /* In a "use bytes" we don't treat the source as UTF-8, but, still want * the destination to retain that flag */ - if (SvUTF8(source)) + if (SvUTF8(source) && ! IN_BYTES) SvUTF8_on(dest); if (!inplace) { /* Finish the rest of the string, unchanged */ @@ -3670,6 +3718,12 @@ PP(pp_ucfirst) SvCUR_set(dest, need - 1); } } +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { + TAINT; + SvTAINTED_on(dest); + } +#endif if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); @@ -3681,7 +3735,6 @@ PP(pp_ucfirst) of the three tight loops. There is less and less commonality though */ PP(pp_uc) { - dVAR; dSP; SV *source = TOPs; STRLEN len; @@ -3692,17 +3745,29 @@ PP(pp_uc) SvGETMAGIC(source); - if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source) - && SvTEMP(source) && !DO_UTF8(source) - && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) { - - /* We can convert in place. The reason we can't if in UNI_8_BIT is to - * make the loop tight, so we overwrite the source with the dest before - * looking at it, and we need to look at the original source - * afterwards. There would also need to be code added to handle - * switching to not in-place in midstream if we run into characters - * that change the length. - */ + if ((SvPADTMP(source) + || + (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1)) + && !SvREADONLY(source) && SvPOK(source) + && !DO_UTF8(source) + && ( +#ifdef USE_LOCALE_CTYPE + (IN_LC_RUNTIME(LC_CTYPE)) + ? ! IN_UTF8_CTYPE_LOCALE + : +#endif + ! IN_UNI_8_BIT)) + { + + /* We can convert in place. The reason we can't if in UNI_8_BIT is to + * make the loop tight, so we overwrite the source with the dest before + * looking at it, and we need to look at the original source + * afterwards. There would also need to be code added to handle + * switching to not in-place in midstream if we run into characters + * that change the length. Since being in locale overrides UNI_8_BIT, + * that latter becomes irrelevant in the above test; instead for + * locale, the size can't normally change, except if the locale is a + * UTF-8 one */ dest = source; s = d = (U8*)SvPV_force_nomg(source, len); min = len + 1; @@ -3711,21 +3776,7 @@ PP(pp_uc) dest = TARG; - /* The old implementation would copy source into TARG at this point. - This had the side effect that if source was undef, TARG was now - an undefined SV with PADTMP set, and they don't warn inside - sv_2pv_flags(). However, we're now getting the PV direct from - source, which doesn't have PADTMP set, so it would warn. Hence the - little games. */ - - if (SvOK(source)) { - s = (const U8*)SvPV_nomg_const(source, len); - } else { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(source); - s = (const U8*)""; - len = 0; - } + s = (const U8*)SvPV_nomg_const(source, len); min = len + 1; SvUPGRADE(dest, SVt_PV); @@ -3740,8 +3791,7 @@ PP(pp_uc) if (DO_UTF8(source)) { const U8 *const send = s + len; - U8 tmpbuf[UTF8_MAXBYTES+1]; - bool tainted = FALSE; + U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; /* All occurrences of these are to be moved to follow any other marks. * This is context-dependent. We may not be passed enough context to @@ -3762,10 +3812,8 @@ PP(pp_uc) if (in_iota_subscript && ! _is_utf8_mark(s)) { /* A non-mark. Time to output the iota subscript */ -#define GREEK_CAPITAL_LETTER_IOTA 0x0399 -#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345 - - CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA); + Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8); + d += capital_iota_len; in_iota_subscript = FALSE; } @@ -3773,8 +3821,13 @@ PP(pp_uc) * and copy it to the output buffer */ u = UTF8SKIP(s); - uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, - cBOOL(IN_LOCALE_RUNTIME), &tainted); +#ifdef USE_LOCALE_CTYPE + uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); +#else + uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0); +#endif +#define GREEK_CAPITAL_LETTER_IOTA 0x0399 +#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345 if (uv == GREEK_CAPITAL_LETTER_IOTA && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI) { @@ -3800,16 +3853,13 @@ PP(pp_uc) s += u; } if (in_iota_subscript) { - CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA); + Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8); + d += capital_iota_len; } SvUTF8_on(dest); *d = '\0'; SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - if (tainted) { - TAINT; - SvTAINTED_on(dest); - } } else { /* Not UTF-8 */ if (len) { @@ -3818,18 +3868,25 @@ PP(pp_uc) /* Use locale casing if in locale; regular style if not treating * latin1 as having case; otherwise the latin1 casing. Do the * whole thing in a tight loop, for speed, */ - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(dest); +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { + if (IN_UTF8_CTYPE_LOCALE) { + goto do_uni_rules; + } for (; s < send; d++, s++) - *d = toUPPER_LC(*s); + *d = (U8) toUPPER_LC(*s); } - else if (! IN_UNI_8_BIT) { + else +#endif + if (! IN_UNI_8_BIT) { for (; s < send; d++, s++) { *d = toUPPER(*s); } } else { +#ifdef USE_LOCALE_CTYPE + do_uni_rules: +#endif for (; s < send; d++, s++) { *d = toUPPER_LATIN1_MOD(*s); if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) { @@ -3918,6 +3975,12 @@ PP(pp_uc) SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); } } /* End of isn't utf8 */ +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { + TAINT; + SvTAINTED_on(dest); + } +#endif if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); @@ -3926,7 +3989,6 @@ PP(pp_uc) PP(pp_lc) { - dVAR; dSP; SV *source = TOPs; STRLEN len; @@ -3937,8 +3999,12 @@ PP(pp_lc) SvGETMAGIC(source); - if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source) - && SvTEMP(source) && !DO_UTF8(source)) { + if ( ( SvPADTMP(source) + || ( SvTEMP(source) && !SvSMAGICAL(source) + && SvREFCNT(source) == 1 ) + ) + && !SvREADONLY(source) && SvPOK(source) + && !DO_UTF8(source)) { /* We can convert in place, as lowercasing anything in the latin1 range * (or else DO_UTF8 would have been on) doesn't lengthen it */ @@ -3950,21 +4016,7 @@ PP(pp_lc) dest = TARG; - /* The old implementation would copy source into TARG at this point. - This had the side effect that if source was undef, TARG was now - an undefined SV with PADTMP set, and they don't warn inside - sv_2pv_flags(). However, we're now getting the PV direct from - source, which doesn't have PADTMP set, so it would warn. Hence the - little games. */ - - if (SvOK(source)) { - s = (const U8*)SvPV_nomg_const(source, len); - } else { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(source); - s = (const U8*)""; - len = 0; - } + s = (const U8*)SvPV_nomg_const(source, len); min = len + 1; SvUPGRADE(dest, SVt_PV); @@ -3980,17 +4032,19 @@ PP(pp_lc) if (DO_UTF8(source)) { const U8 *const send = s + len; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - bool tainted = FALSE; while (s < send) { const STRLEN u = UTF8SKIP(s); STRLEN ulen; - _to_utf8_lower_flags(s, tmpbuf, &ulen, - cBOOL(IN_LOCALE_RUNTIME), &tainted); +#ifdef USE_LOCALE_CTYPE + _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE)); +#else + _to_utf8_lower_flags(s, tmpbuf, &ulen, 0); +#endif /* Here is where we would do context-sensitive actions. See the - * commit message for this comment for why there isn't any */ + * commit message for 86510fb15 for why there isn't any */ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { @@ -4017,10 +4071,6 @@ PP(pp_lc) SvUTF8_on(dest); *d = '\0'; SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - if (tainted) { - TAINT; - SvTAINTED_on(dest); - } } else { /* Not utf8 */ if (len) { const U8 *const send = s + len; @@ -4028,13 +4078,14 @@ PP(pp_lc) /* Use locale casing if in locale; regular style if not treating * latin1 as having case; otherwise the latin1 casing. Do the * whole thing in a tight loop, for speed, */ - if (IN_LOCALE_RUNTIME) { - TAINT; - SvTAINTED_on(dest); +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { for (; s < send; d++, s++) *d = toLOWER_LC(*s); - } - else if (! IN_UNI_8_BIT) { + } + else +#endif + if (! IN_UNI_8_BIT) { for (; s < send; d++, s++) { *d = toLOWER(*s); } @@ -4050,6 +4101,12 @@ PP(pp_lc) SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); } } +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { + TAINT; + SvTAINTED_on(dest); + } +#endif if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); @@ -4058,7 +4115,7 @@ PP(pp_lc) PP(pp_quotemeta) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; STRLEN len; const char *s = SvPV_const(sv,len); @@ -4080,11 +4137,15 @@ PP(pp_quotemeta) } } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { - + if ( +#ifdef USE_LOCALE_CTYPE /* In locale, we quote all non-ASCII Latin1 chars. * Otherwise use the quoting rules */ - if (IN_LOCALE_RUNTIME - || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1)))) + + IN_LC_RUNTIME(LC_CTYPE) + || +#endif + _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1)))) { to_quote = TRUE; } @@ -4132,7 +4193,6 @@ PP(pp_quotemeta) PP(pp_fc) { - dVAR; dTARGET; dSP; SV *source = TOPs; @@ -4142,10 +4202,14 @@ PP(pp_fc) const U8 *s; const U8 *send; U8 *d; - U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1]; - const bool full_folding = TRUE; + U8 tmpbuf[UTF8_MAXBYTES_CASE + 1]; + const bool full_folding = TRUE; /* This variable is here so we can easily + move to more generality later */ const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 ) - | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 ); +#ifdef USE_LOCALE_CTYPE + | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 ) +#endif + ; /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me. * You are welcome(?) -Hugmeir @@ -4174,12 +4238,11 @@ PP(pp_fc) send = s + len; if (DO_UTF8(source)) { /* UTF-8 flagged string. */ - bool tainted = FALSE; while (s < send) { const STRLEN u = UTF8SKIP(s); STRLEN ulen; - _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted); + _to_utf8_fold_flags(s, tmpbuf, &ulen, flags); if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { const UV o = d - (U8*)SvPVX_const(dest); @@ -4192,29 +4255,29 @@ PP(pp_fc) s += u; } SvUTF8_on(dest); - if (tainted) { - TAINT; - SvTAINTED_on(dest); - } } /* Unflagged string */ else if (len) { - /* For locale, bytes, and nothing, the behavior is supposed to be the - * same as lc(). - */ - if ( IN_LOCALE_RUNTIME ) { /* Under locale */ - TAINT; - SvTAINTED_on(dest); +#ifdef USE_LOCALE_CTYPE + if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ + if (IN_UTF8_CTYPE_LOCALE) { + goto do_uni_folding; + } for (; s < send; d++, s++) - *d = toLOWER_LC(*s); + *d = (U8) toFOLD_LC(*s); } - else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */ + else +#endif + if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */ for (; s < send; d++, s++) - *d = toLOWER(*s); + *d = toFOLD(*s); } else { +#ifdef USE_LOCALE_CTYPE + do_uni_folding: +#endif /* For ASCII and the Latin-1 range, there's only two troublesome * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full - * casefolding becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which + * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) -- * For the rest, the casefold is their lowercase. */ for (; s < send; d++, s++) { @@ -4234,12 +4297,13 @@ PP(pp_fc) (send -s) * 2 + 1); d = (U8*)SvPVX(dest) + len; - CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU); + Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8); + d += small_mu_len; s++; for (; s < send; s++) { STRLEN ulen; UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags); - if UNI_IS_INVARIANT(fc) { + if UVCHR_IS_INVARIANT(fc) { if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) { @@ -4277,6 +4341,12 @@ PP(pp_fc) *d = '\0'; SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { + TAINT; + SvTAINTED_on(dest); + } +#endif if (SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); @@ -4287,7 +4357,7 @@ PP(pp_fc) PP(pp_aslice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; AV *const av = MUTABLE_AV(POPs); const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); @@ -4304,9 +4374,9 @@ PP(pp_aslice) if (lval && localizing) { SV **svp; - I32 max = -1; + SSize_t max = -1; for (svp = MARK + 1; svp <= SP; svp++) { - const I32 elem = SvIV(*svp); + const SSize_t elem = SvIV(*svp); if (elem > max) max = elem; } @@ -4316,7 +4386,7 @@ PP(pp_aslice) while (++MARK <= SP) { SV **svp; - I32 elem = SvIV(*MARK); + SSize_t elem = SvIV(*MARK); bool preeminent = TRUE; if (localizing && can_preserve) { @@ -4329,7 +4399,7 @@ PP(pp_aslice) svp = av_fetch(av, elem, lval); if (lval) { - if (!svp || *svp == &PL_sv_undef) + if (!svp || !*svp) DIE(aTHX_ PL_no_aelem, elem); if (localizing) { if (preeminent) @@ -4349,10 +4419,54 @@ PP(pp_aslice) RETURN; } +PP(pp_kvaslice) +{ + dSP; dMARK; + AV *const av = MUTABLE_AV(POPs); + I32 lval = (PL_op->op_flags & OPf_MOD); + SSize_t items = SP - MARK; + + if (PL_op->op_private & OPpMAYBE_LVSUB) { + const I32 flags = is_lvalue_sub(); + if (flags) { + if (!(flags & OPpENTERSUB_INARGS)) + /* diag_listed_as: Can't modify %s in %s */ + Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment"); + lval = flags; + } + } + + MEXTEND(SP,items); + while (items > 1) { + *(MARK+items*2-1) = *(MARK+items); + items--; + } + items = SP-MARK; + SP += items; + + while (++MARK <= SP) { + SV **svp; + + svp = av_fetch(av, SvIV(*MARK), lval); + if (lval) { + if (!svp || !*svp || *svp == &PL_sv_undef) { + DIE(aTHX_ PL_no_aelem, SvIV(*MARK)); + } + *MARK = sv_mortalcopy(*MARK); + } + *++MARK = svp ? *svp : &PL_sv_undef; + } + if (GIMME != G_ARRAY) { + MARK = SP - items*2; + *++MARK = items > 0 ? *SP : &PL_sv_undef; + SP = MARK; + } + RETURN; +} + /* Smart dereferencing for keys, values and each */ PP(pp_rkeys) { - dVAR; dSP; dPOPss; @@ -4390,14 +4504,13 @@ PP(pp_rkeys) PP(pp_aeach) { - dVAR; dSP; AV *array = MUTABLE_AV(POPs); const I32 gimme = GIMME_V; IV *iterp = Perl_av_iter_p(aTHX_ array); const IV current = (*iterp)++; - if (current > av_len(array)) { + if (current > av_tindex(array)) { *iterp = 0; if (gimme == G_SCALAR) RETPUSHUNDEF; @@ -4416,7 +4529,6 @@ PP(pp_aeach) PP(pp_akeys) { - dVAR; dSP; AV *array = MUTABLE_AV(POPs); const I32 gimme = GIMME_V; @@ -4425,7 +4537,7 @@ PP(pp_akeys) if (gimme == G_SCALAR) { dTARGET; - PUSHi(av_len(array) + 1); + PUSHi(av_tindex(array) + 1); } else if (gimme == G_ARRAY) { IV n = Perl_av_len(aTHX_ array); @@ -4452,7 +4564,6 @@ PP(pp_akeys) PP(pp_each) { - dVAR; dSP; HV * hash = MUTABLE_HV(POPs); HE *entry; @@ -4485,21 +4596,20 @@ PP(pp_each) STATIC OP * S_do_delete_local(pTHX) { - dVAR; dSP; const I32 gimme = GIMME_V; const MAGIC *mg; HV *stash; const bool sliced = !!(PL_op->op_private & OPpSLICE); - SV *unsliced_keysv = sliced ? NULL : POPs; + SV **unsliced_keysv = sliced ? NULL : sp--; SV * const osv = POPs; - SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1; + SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1; dORIGMARK; const bool tied = SvRMAGICAL(osv) && mg_find((const SV *)osv, PERL_MAGIC_tied); const bool can_preserve = SvCANEXISTDELETE(osv); const U32 type = SvTYPE(osv); - SV ** const end = sliced ? SP : &unsliced_keysv; + SV ** const end = sliced ? SP : unsliced_keysv; if (type == SVt_PVHV) { /* hash element */ HV * const hv = MUTABLE_HV(osv); @@ -4518,7 +4628,8 @@ S_do_delete_local(pTHX) } else { sv = hv_delete_ent(hv, keysv, 0, 0); - SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + if (preeminent) + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ } if (preeminent) { if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); @@ -4539,7 +4650,7 @@ S_do_delete_local(pTHX) if (PL_op->op_flags & OPf_SPECIAL) { AV * const av = MUTABLE_AV(osv); while (++MARK <= end) { - I32 idx = SvIV(*MARK); + SSize_t idx = SvIV(*MARK); SV *sv = NULL; bool preeminent = TRUE; if (can_preserve) @@ -4553,7 +4664,8 @@ S_do_delete_local(pTHX) } else { sv = av_delete(av, idx, 0); - SvREFCNT_inc_simple_void(sv); /* De-mortalize */ + if (preeminent) + SvREFCNT_inc_simple_void(sv); /* De-mortalize */ } if (preeminent) { save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM); @@ -4587,14 +4699,13 @@ S_do_delete_local(pTHX) } } else if (gimme != G_VOID) - PUSHs(unsliced_keysv); + PUSHs(*unsliced_keysv); RETURN; } PP(pp_delete) { - dVAR; dSP; I32 gimme; I32 discard; @@ -4660,12 +4771,11 @@ PP(pp_delete) PP(pp_exists) { - dVAR; dSP; SV *tmpsv; HV *hv; - if (PL_op->op_private & OPpEXISTS_SUB) { + if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) { GV *gv; SV * const sv = POPs; CV * const cv = sv_2cv(sv, &hv, &gv, 0); @@ -4677,7 +4787,7 @@ PP(pp_exists) } tmpsv = POPs; hv = MUTABLE_HV(POPs); - if (SvTYPE(hv) == SVt_PVHV) { + if (LIKELY( SvTYPE(hv) == SVt_PVHV )) { if (hv_exists_ent(hv, tmpsv, 0)) RETPUSHYES; } @@ -4695,7 +4805,7 @@ PP(pp_exists) PP(pp_hslice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV * const hv = MUTABLE_HV(POPs); const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); const bool localizing = PL_op->op_private & OPpLVAL_INTRO; @@ -4750,30 +4860,82 @@ PP(pp_hslice) RETURN; } +PP(pp_kvhslice) +{ + dSP; dMARK; + HV * const hv = MUTABLE_HV(POPs); + I32 lval = (PL_op->op_flags & OPf_MOD); + SSize_t items = SP - MARK; + + if (PL_op->op_private & OPpMAYBE_LVSUB) { + const I32 flags = is_lvalue_sub(); + if (flags) { + if (!(flags & OPpENTERSUB_INARGS)) + /* diag_listed_as: Can't modify %s in %s */ + Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment"); + lval = flags; + } + } + + MEXTEND(SP,items); + while (items > 1) { + *(MARK+items*2-1) = *(MARK+items); + items--; + } + items = SP-MARK; + SP += items; + + while (++MARK <= SP) { + SV * const keysv = *MARK; + SV **svp; + HE *he; + + he = hv_fetch_ent(hv, keysv, lval, 0); + svp = he ? &HeVAL(he) : NULL; + + if (lval) { + if (!svp || !*svp || *svp == &PL_sv_undef) { + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + } + *MARK = sv_mortalcopy(*MARK); + } + *++MARK = svp && *svp ? *svp : &PL_sv_undef; + } + if (GIMME != G_ARRAY) { + MARK = SP - items*2; + *++MARK = items > 0 ? *SP : &PL_sv_undef; + SP = MARK; + } + RETURN; +} + /* List operators. */ PP(pp_list) { - dVAR; dSP; dMARK; + I32 markidx = POPMARK; if (GIMME != G_ARRAY) { + SV **mark = PL_stack_base + markidx; + dSP; if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ else *MARK = &PL_sv_undef; SP = MARK; + PUTBACK; } - RETURN; + return NORMAL; } 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; SV ** const firstrelem = lastlelem + 1; I32 is_something_there = FALSE; + const U8 mod = PL_op->op_flags & OPf_MOD; const I32 max = lastrelem - lastlelem; SV **lelem; @@ -4805,6 +4967,10 @@ PP(pp_lslice) is_something_there = TRUE; if (!(*lelem = firstrelem[ix])) *lelem = &PL_sv_undef; + else if (mod && SvPADTMP(*lelem)) { + assert(!IS_PADGV(*lelem)); + *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); + } } } if (is_something_there) @@ -4816,10 +4982,10 @@ PP(pp_lslice) PP(pp_anonlist) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; const I32 items = SP - MARK; SV * const av = MUTABLE_SV(av_make(items, MARK+1)); - SP = ORIGMARK; /* av_make() might realloc stack_sp */ + SP = MARK; mXPUSHs((PL_op->op_flags & OPf_SPECIAL) ? newRV_noinc(av) : av); RETURN; @@ -4827,8 +4993,11 @@ PP(pp_anonlist) PP(pp_anonhash) { - dVAR; dSP; dMARK; dORIGMARK; - HV* const hv = (HV *)sv_2mortal((SV *)newHV()); + dSP; dMARK; dORIGMARK; + HV* const hv = newHV(); + SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL + ? newRV_noinc(MUTABLE_SV(hv)) + : MUTABLE_SV(hv) ); while (MARK < SP) { SV * const key = @@ -4849,9 +5018,7 @@ PP(pp_anonhash) (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; - if (PL_op->op_flags & OPf_SPECIAL) - mXPUSHs(newRV_inc(MUTABLE_SV(hv))); - else XPUSHs(MUTABLE_SV(hv)); + XPUSHs(retval); RETURN; } @@ -4887,21 +5054,21 @@ S_deref_plain_array(pTHX_ AV *ary) PP(pp_splice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; int num_args = (SP - MARK); AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); SV **src; SV **dst; - I32 i; - I32 offset; - I32 length; - I32 newlen; - I32 after; - I32 diff; + SSize_t i; + SSize_t offset; + SSize_t length; + SSize_t newlen; + SSize_t after; + SSize_t diff; const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { - return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg, + return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg, GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK, sp - mark); } @@ -4964,14 +5131,18 @@ PP(pp_splice) MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ + const bool real = cBOOL(AvREAL(ary)); MEXTEND(MARK, length); - Copy(AvARRAY(ary)+offset, MARK, length, SV*); - if (AvREAL(ary)) { + if (real) EXTEND_MORTAL(length); - for (i = length, dst = MARK; i; i--) { + for (i = 0, dst = MARK; i < length; i++) { + if ((*dst = AvARRAY(ary)[i+offset])) { + if (real) sv_2mortal(*dst); /* free them eventually */ - dst++; } + else + *dst = &PL_sv_undef; + dst++; } MARK += length - 1; } @@ -5009,7 +5180,7 @@ PP(pp_splice) } i = -diff; while (i) - dst[--i] = &PL_sv_undef; + dst[--i] = NULL; if (newlen) { Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* ); @@ -5057,13 +5228,16 @@ PP(pp_splice) MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ if (length) { - Copy(tmparyval, MARK, length, SV*); - if (AvREAL(ary)) { + const bool real = cBOOL(AvREAL(ary)); + if (real) EXTEND_MORTAL(length); - for (i = length, dst = MARK; i; i--) { + for (i = 0, dst = MARK; i < length; i++) { + if ((*dst = tmparyval[i])) { + if (real) sv_2mortal(*dst); /* free them eventually */ - dst++; } + else *dst = &PL_sv_undef; + dst++; } } MARK += length - 1; @@ -5090,7 +5264,7 @@ PP(pp_splice) PP(pp_push) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); @@ -5099,7 +5273,7 @@ PP(pp_push) PUSHMARK(MARK); PUTBACK; ENTER_with_name("call_PUSH"); - call_method("PUSH",G_SCALAR|G_DISCARD); + call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); LEAVE_with_name("call_PUSH"); SPAGAIN; } @@ -5128,7 +5302,6 @@ PP(pp_push) PP(pp_shift) { - dVAR; dSP; AV * const av = PL_op->op_flags & OPf_SPECIAL ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs)); @@ -5143,7 +5316,7 @@ PP(pp_shift) PP(pp_unshift) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); @@ -5152,12 +5325,12 @@ PP(pp_unshift) PUSHMARK(MARK); PUTBACK; ENTER_with_name("call_UNSHIFT"); - call_method("UNSHIFT",G_SCALAR|G_DISCARD); + call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED); LEAVE_with_name("call_UNSHIFT"); SPAGAIN; } else { - I32 i = 0; + SSize_t i = 0; av_unshift(ary, SP - MARK); while (MARK < SP) { SV * const sv = newSVsv(*++MARK); @@ -5173,7 +5346,7 @@ PP(pp_unshift) PP(pp_reverse) { - dVAR; dSP; dMARK; + dSP; dMARK; if (GIMME == G_ARRAY) { if (PL_op->op_private & OPpREVERSE_INPLACE) { @@ -5188,14 +5361,14 @@ PP(pp_reverse) SP = MARK; if (SvMAGICAL(av)) { - I32 i, j; + SSize_t i, j; SV *tmp = sv_newmortal(); /* For SvCANEXISTDELETE */ HV *stash; const MAGIC *mg; bool can_preserve = SvCANEXISTDELETE(av); - for (i = 0, j = av_len(av); i < j; ++i, --j) { + for (i = 0, j = av_tindex(av); i < j; ++i, --j) { SV *begin, *end; if (can_preserve) { @@ -5260,8 +5433,6 @@ PP(pp_reverse) do_join(TARG, &PL_sv_no, MARK, SP); else { sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv()); - if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED)) - report_uninit(TARG); } up = SvPV_force(TARG, len); @@ -5306,7 +5477,7 @@ PP(pp_reverse) PP(pp_split) { - dVAR; dSP; dTARG; + dSP; dTARG; AV *ary; IV limit = POPi; /* note, negative is forever */ SV * const sv = POPs; @@ -5318,11 +5489,11 @@ PP(pp_split) REGEXP *rx; SV *dstr; const char *m; - I32 iters = 0; + SSize_t iters = 0; const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s); - I32 maxiters = slen + 10; + SSize_t maxiters = slen + 10; I32 trailing_empty = 0; const char *orig; const I32 origlimit = limit; @@ -5347,8 +5518,6 @@ PP(pp_split) TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET && (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE))); - RX_MATCH_UTF8_set(rx, do_utf8); - #ifdef USE_ITHREADS if (pm->op_pmreplrootu.op_pmtargetoff) { ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff))); @@ -5548,7 +5717,7 @@ PP(pp_split) else if (do_utf8 == (RX_UTF8(rx) != 0) && (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx) && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL) - && !(RX_EXTFLAGS(rx) & RXf_ANCH)) { + && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) { const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL); SV * const csv = CALLREG_INTUIT_STRING(rx); @@ -5712,11 +5881,11 @@ PP(pp_split) else { PUTBACK; ENTER_with_name("call_PUSH"); - call_method("PUSH",G_SCALAR|G_DISCARD); + call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); LEAVE_with_name("call_PUSH"); SPAGAIN; if (gimme == G_ARRAY) { - I32 i; + SSize_t i; /* EXTEND should not be needed - we just popped them */ EXTEND(SP, iters); for (i=0; i < iters; i++) { @@ -5752,7 +5921,6 @@ PP(pp_once) PP(pp_lock) { - dVAR; dSP; dTOPss; SV *retsv = sv; @@ -5768,7 +5936,6 @@ PP(pp_lock) PP(unimplemented_op) { - dVAR; const Optype op_type = PL_op->op_type; /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope with out of range op numbers - it only "special" cases op_custom. @@ -5878,7 +6045,7 @@ PP(pp_coreargs) const bool constr = PL_op->op_private & whicharg; PUSHs(S_rv2gv(aTHX_ svp && *svp ? *svp : &PL_sv_undef, - constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS, + constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS), !constr )); } @@ -5900,7 +6067,6 @@ PP(pp_coreargs) ) ) DIE(aTHX_ - /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ "Type of arg %d to &CORE::%s must be %s", whicharg, PL_op_name[opnum], wantscalar