X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6174b39a88cd48740c024cfb6035edb6ffed9f2d..7a11f5c382a3ea35768e2f50d7dbeaed6adc2398:/pp.c diff --git a/pp.c b/pp.c index cadfe96..ea05bb4 100644 --- a/pp.c +++ b/pp.c @@ -54,7 +54,6 @@ static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - PP(pp_stub) { - dVAR; dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); @@ -65,7 +64,7 @@ PP(pp_stub) PP(pp_padav) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVAV); if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) @@ -88,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); } @@ -113,7 +116,7 @@ PP(pp_padav) PP(pp_padhv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVHV); @@ -150,7 +153,7 @@ PP(pp_padhv) PP(pp_padcv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; assert(SvTYPE(TARG) == SVt_PVCV); XPUSHs(TARG); RETURN; @@ -158,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); @@ -207,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)) { @@ -222,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)) { @@ -246,6 +249,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, 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)); @@ -253,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; @@ -267,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 @@ -299,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, @@ -318,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; @@ -361,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); @@ -409,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) { @@ -427,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 */ @@ -442,7 +446,7 @@ PP(pp_pos) if (mg && mg->mg_len != -1) { dTARGET; STRLEN i = mg->mg_len; - if (DO_UTF8(sv)) + if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv)) i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN); PUSHu(i); RETURN; @@ -453,7 +457,7 @@ PP(pp_pos) PP(pp_rv2cv) { - dVAR; dSP; + dSP; GV *gv; HV *stash_unused; const I32 flags = (PL_op->op_flags & OPf_SPECIAL) @@ -468,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); @@ -478,7 +484,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - dVAR; dSP; + dSP; CV *cv; HV *stash; GV *gv; @@ -489,7 +495,7 @@ 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) + if (!code) DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"", UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6)); { @@ -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,21 +589,26 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - dVAR; dSP; dTARGET; - SV * const sv = POPs; + dSP; + SV * const sv = TOPs; SvGETMAGIC(sv); if (!SvROK(sv)) - RETPUSHNO; + 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) @@ -612,9 +624,19 @@ PP(pp_bless) 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)"); @@ -627,7 +649,7 @@ PP(pp_bless) PP(pp_gelem) { - dVAR; dSP; + dSP; SV *sv = POPs; STRLEN len; @@ -706,7 +728,7 @@ PP(pp_gelem) PP(pp_study) { - dVAR; dSP; dPOPss; + dSP; dPOPss; STRLEN len; (void)SvPV(sv, len); @@ -722,7 +744,7 @@ PP(pp_study) PP(pp_trans) { - dVAR; dSP; dTARG; + dSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) @@ -752,7 +774,6 @@ PP(pp_trans) static void S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) { - dVAR; STRLEN len; char *s; @@ -916,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) @@ -928,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) @@ -942,7 +963,7 @@ PP(pp_chop) PP(pp_undef) { - dVAR; dSP; + dSP; SV *sv; if (!PL_op->op_private) { @@ -954,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: @@ -1010,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); @@ -1048,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))) @@ -1077,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 @@ -1244,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; @@ -1366,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; @@ -1486,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; @@ -1613,7 +1638,7 @@ PP(pp_modulo) PP(pp_repeat) { - dVAR; dSP; dATARGET; + dSP; dATARGET; IV count; SV *sv; @@ -1635,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? */ @@ -1689,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--; } @@ -1748,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; @@ -1867,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; @@ -1887,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; @@ -1907,7 +1940,7 @@ PP(pp_right_shift) PP(pp_lt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric); @@ -1923,7 +1956,7 @@ PP(pp_lt) PP(pp_gt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric); @@ -1939,7 +1972,7 @@ PP(pp_gt) PP(pp_le) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric); @@ -1955,7 +1988,7 @@ PP(pp_le) PP(pp_ge) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric); @@ -1971,7 +2004,7 @@ PP(pp_ge) PP(pp_ne) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric); @@ -1994,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 */ @@ -2061,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); @@ -2080,7 +2111,7 @@ PP(pp_ncmp) PP(pp_sle) { - dVAR; dSP; + dSP; int amg_type = sle_amg; int multiplier = 1; @@ -2108,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; } @@ -2118,7 +2153,7 @@ PP(pp_sle) PP(pp_seq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(seq_amg, AMGf_set); { dPOPTOPssrl; @@ -2129,7 +2164,7 @@ PP(pp_seq) PP(pp_sne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(sne_amg, AMGf_set); { dPOPTOPssrl; @@ -2140,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; } @@ -2154,7 +2193,7 @@ PP(pp_scmp) PP(pp_bit_and) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(band_amg, AMGf_assign); { dPOPTOPssrl; @@ -2182,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); @@ -2239,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; { @@ -2283,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; @@ -2291,7 +2330,7 @@ PP(pp_not) PP(pp_complement) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(compl_amg, AMGf_numeric); { dTOPss; @@ -2310,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. */ @@ -2393,7 +2431,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(mult_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2405,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; @@ -2432,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; @@ -2455,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; @@ -2516,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; @@ -2527,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; @@ -2538,7 +2576,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(lt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2549,7 +2587,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(gt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2560,7 +2598,7 @@ PP(pp_i_gt) PP(pp_i_le) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(le_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2571,7 +2609,7 @@ PP(pp_i_le) PP(pp_i_ge) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ge_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2582,7 +2620,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(eq_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2593,7 +2631,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ne_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2604,7 +2642,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(ncmp_amg, 0); { dPOPTOPiirl_nomg; @@ -2623,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; { @@ -2638,7 +2676,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(atan2_amg, 0); { dPOPTOPnnrl_nomg; @@ -2649,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; } } @@ -2704,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; @@ -2745,7 +2774,7 @@ PP(pp_rand) PP(pp_srand) { - dVAR; dSP; dTARGET; + dSP; dTARGET; UV anum; if (MAXARG >= 1 && (TOPs || POPs)) { @@ -2783,7 +2812,7 @@ PP(pp_srand) PP(pp_int) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(int_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2825,7 +2854,7 @@ PP(pp_int) PP(pp_abs) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(abs_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2865,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; @@ -2890,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); @@ -2912,7 +2941,7 @@ PP(pp_oct) PP(pp_length) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; SvGETMAGIC(sv); @@ -2940,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; @@ -3004,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; @@ -3143,7 +3172,7 @@ bound_fail: PP(pp_vec) { - dVAR; dSP; + dSP; const IV size = POPi; const IV offset = POPi; SV * const src = POPs; @@ -3171,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; @@ -3261,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, @@ -3278,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: @@ -3288,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)); @@ -3299,7 +3328,7 @@ PP(pp_sprintf) PP(pp_ord) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *argsv = POPs; STRLEN len; @@ -3308,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); @@ -3388,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); @@ -3444,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. */ @@ -3462,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, @@ -3491,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. */ @@ -3514,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); @@ -3630,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; } @@ -3659,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 */ @@ -3668,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); @@ -3679,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; @@ -3690,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; @@ -3709,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); @@ -3739,7 +3792,6 @@ PP(pp_uc) if (DO_UTF8(source)) { const U8 *const send = s + len; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - bool tainted = FALSE; /* 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 @@ -3769,8 +3821,11 @@ 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 @@ -3805,10 +3860,6 @@ PP(pp_uc) *d = '\0'; SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - if (tainted) { - TAINT; - SvTAINTED_on(dest); - } } else { /* Not UTF-8 */ if (len) { @@ -3817,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)) { @@ -3917,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); @@ -3925,7 +3989,6 @@ PP(pp_uc) PP(pp_lc) { - dVAR; dSP; SV *source = TOPs; STRLEN len; @@ -3936,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 */ @@ -3949,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); @@ -3979,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))) { @@ -4016,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; @@ -4027,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); } @@ -4049,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); @@ -4057,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); @@ -4079,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; } @@ -4131,7 +4193,6 @@ PP(pp_quotemeta) PP(pp_fc) { - dVAR; dTARGET; dSP; SV *source = TOPs; @@ -4142,9 +4203,13 @@ PP(pp_fc) const U8 *send; U8 *d; U8 tmpbuf[UTF8_MAXBYTES_CASE + 1]; - const bool full_folding = TRUE; + 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 @@ -4173,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); @@ -4191,23 +4255,26 @@ PP(pp_fc) s += u; } SvUTF8_on(dest); - if (tainted) { - TAINT; - SvTAINTED_on(dest); - } } /* Unflagged string */ else if (len) { - 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 = toFOLD_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 = 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 @@ -4236,7 +4303,7 @@ PP(pp_fc) 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) { @@ -4274,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); @@ -4284,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); @@ -4301,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; } @@ -4313,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) { @@ -4326,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) @@ -4346,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; @@ -4387,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; @@ -4413,7 +4529,6 @@ PP(pp_aeach) PP(pp_akeys) { - dVAR; dSP; AV *array = MUTABLE_AV(POPs); const I32 gimme = GIMME_V; @@ -4422,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); @@ -4449,7 +4564,6 @@ PP(pp_akeys) PP(pp_each) { - dVAR; dSP; HV * hash = MUTABLE_HV(POPs); HE *entry; @@ -4482,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); @@ -4537,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) @@ -4586,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; @@ -4659,7 +4771,6 @@ PP(pp_delete) PP(pp_exists) { - dVAR; dSP; SV *tmpsv; HV *hv; @@ -4694,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; @@ -4749,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; @@ -4804,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) @@ -4815,7 +4982,7 @@ PP(pp_lslice) PP(pp_anonlist) { - dVAR; dSP; dMARK; + dSP; dMARK; const I32 items = SP - MARK; SV * const av = MUTABLE_SV(av_make(items, MARK+1)); SP = MARK; @@ -4826,7 +4993,7 @@ PP(pp_anonlist) PP(pp_anonhash) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV* const hv = newHV(); SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL ? newRV_noinc(MUTABLE_SV(hv)) @@ -4887,17 +5054,17 @@ 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) { @@ -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); @@ -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); @@ -5157,7 +5330,7 @@ PP(pp_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; @@ -5546,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); @@ -5714,7 +5885,7 @@ PP(pp_split) 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++) { @@ -5750,7 +5921,6 @@ PP(pp_once) PP(pp_lock) { - dVAR; dSP; dTOPss; SV *retsv = sv; @@ -5766,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. @@ -5876,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 )); } @@ -5898,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