X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6d59e610a3f269be73ffea56a90d1cd7dc8bf2fd..aec1aee98641bc6f9ad658677f98ce6915bd139a:/pp.c diff --git a/pp.c b/pp.c index 6d575f7..b084d49 100644 --- a/pp.c +++ b/pp.c @@ -78,7 +78,7 @@ PP(pp_padav) } else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME == G_SCALAR) + if (GIMME_V == G_SCALAR) /* diag_listed_as: Can't return %s to lvalue scalar context */ Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); PUSHs(TARG); @@ -88,18 +88,18 @@ PP(pp_padav) gimme = GIMME_V; if (gimme == G_ARRAY) { /* XXX see also S_pushav in pp_hot.c */ - const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; + const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { - Size_t i; + SSize_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 { - PADOFFSET i; - for (i=0; i < (PADOFFSET)maxarg; i++) { + SSize_t i; + for (i=0; i < maxarg; i++) { SV * const sv = AvARRAY((const AV *)TARG)[i]; SP[i+1] = sv ? sv : &PL_sv_undef; } @@ -130,7 +130,7 @@ PP(pp_padhv) else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME == G_SCALAR) + if (GIMME_V == G_SCALAR) /* diag_listed_as: Can't return %s to lvalue scalar context */ Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); RETURN; @@ -170,25 +170,24 @@ PP(pp_introcv) PP(pp_clonecv) { dTARGET; - MAGIC * const mg = - mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG], - PERL_MAGIC_proto); + CV * const protocv = PadnamePROTOCV( + PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG] + ); assert(SvTYPE(TARG) == SVt_PVCV); - assert(mg); - assert(mg->mg_obj); - if (CvISXSUB(mg->mg_obj)) { /* constant */ + assert(protocv); + if (CvISXSUB(protocv)) { /* constant */ /* XXX Should we clone it here? */ /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV to introcv and remove the SvPADSTALE_off. */ SAVEPADSVANDMORTALIZE(ARGTARG); - PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj); + PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv); } else { - if (CvROOT(mg->mg_obj)) { - assert(CvCLONE(mg->mg_obj)); - assert(!CvCLONED(mg->mg_obj)); + if (CvROOT(protocv)) { + assert(CvCLONE(protocv)); + assert(!CvCLONED(protocv)); } - cv_clone_into((CV *)mg->mg_obj,(CV *)TARG); + cv_clone_into(protocv,(CV *)TARG); SAVECLEARSV(PAD_SVl(ARGTARG)); } return NORMAL; @@ -196,9 +195,6 @@ PP(pp_clonecv) /* Translations. */ -static const char S_no_symref_sv[] = - "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use"; - /* In some cases this function inspects PL_op. If this function is called for new op types, more bool parameters may need to be added in place of the checks. @@ -275,7 +271,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, else { if (strict) { Perl_die(aTHX_ - S_no_symref_sv, + PL_no_symref_sv, sv, (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol" @@ -330,7 +326,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, if (PL_op->op_private & HINT_STRICT_REFS) { if (SvOK(sv)) - Perl_die(aTHX_ S_no_symref_sv, sv, + Perl_die(aTHX_ PL_no_symref_sv, sv, (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); else Perl_die(aTHX_ PL_no_usym, what); @@ -376,15 +372,8 @@ PP(pp_rv2sv) } sv = SvRV(sv); - switch (SvTYPE(sv)) { - case SVt_PVAV: - case SVt_PVHV: - case SVt_PVCV: - case SVt_PVFM: - case SVt_PVIO: + if (SvTYPE(sv) >= SVt_PVAV) DIE(aTHX_ "Not a SCALAR reference"); - default: NOOP; - } } else { gv = MUTABLE_GV(sv); @@ -432,15 +421,14 @@ PP(pp_av2arylen) PP(pp_pos) { - dSP; dPOPss; + dSP; dTOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0); LvTYPE(ret) = '.'; LvTARG(ret) = SvREFCNT_inc_simple(sv); - PUSHs(ret); /* no SvSETMAGIC */ - RETURN; + SETs(ret); /* no SvSETMAGIC */ } else { const MAGIC * const mg = mg_find_mglob(sv); @@ -449,11 +437,12 @@ PP(pp_pos) 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; + SETu(i); + return NORMAL; } - RETPUSHUNDEF; + SETs(&PL_sv_undef); } + return NORMAL; } PP(pp_rv2cv) @@ -480,7 +469,7 @@ PP(pp_rv2cv) else cv = MUTABLE_CV(&PL_sv_undef); SETs(MUTABLE_SV(cv)); - RETURN; + return NORMAL; } PP(pp_prototype) @@ -531,17 +520,20 @@ PP(pp_srefgen) { dSP; *SP = refto(*SP); - RETURN; + return NORMAL; } PP(pp_refgen) { dSP; dMARK; - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; else + { + MEXTEND(SP, 1); *MARK = &PL_sv_undef; + } *MARK = refto(*MARK); SP = MARK; RETURN; @@ -654,7 +646,7 @@ PP(pp_gelem) SV *sv = POPs; STRLEN len; const char * const elem = SvPV_const(sv, len); - GV * const gv = MUTABLE_GV(POPs); + GV * const gv = MUTABLE_GV(TOPs); SV * tmpRef = NULL; sv = NULL; @@ -720,7 +712,7 @@ PP(pp_gelem) sv_2mortal(sv); else sv = &PL_sv_undef; - XPUSHs(sv); + SETs(sv); RETURN; } @@ -728,18 +720,20 @@ PP(pp_gelem) PP(pp_study) { - dSP; dPOPss; + dSP; dTOPss; STRLEN len; (void)SvPV(sv, len); if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) { /* Historically, study was skipped in these cases. */ - RETPUSHNO; + SETs(&PL_sv_no); + return NORMAL; } /* Make study a no-op. It's no longer useful and its existence complicates matters elsewhere. */ - RETPUSHYES; + SETs(&PL_sv_yes); + return NORMAL; } @@ -747,16 +741,18 @@ PP(pp_study) PP(pp_trans) { - dSP; dTARG; + dSP; SV *sv; if (PL_op->op_flags & OPf_STACKED) sv = POPs; - else if (ARGTARG) - sv = GETTARGET; else { - sv = DEFSV; EXTEND(SP,1); + if (ARGTARG) + sv = PAD_SV(ARGTARG); + else { + sv = DEFSV; + } } if(PL_op->op_type == OP_TRANSR) { STRLEN len; @@ -766,8 +762,8 @@ PP(pp_trans) PUSHs(newsv); } else { - TARG = sv_newmortal(); - PUSHi(do_trans(sv)); + I32 i = do_trans(sv); + mPUSHi(i); } RETURN; } @@ -822,14 +818,13 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) s = SvPV(sv, len); if (chomping) { - char *temp_buffer = NULL; - SV *svrecode = NULL; - if (s && len) { + char *temp_buffer = NULL; + SV *svrecode = NULL; s += --len; if (RsPARA(PL_rs)) { if (*s != '\n') - goto nope; + goto nope_free_nothing; ++count; while (len && s[-1] == '\n') { --len; @@ -853,11 +848,12 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) temp_buffer = (char*)bytes_from_utf8((U8*)rsptr, &rslen, &is_utf8); if (is_utf8) { - /* Cannot downgrade, therefore cannot possibly match + /* Cannot downgrade, therefore cannot possibly match. + At this point, temp_buffer is not alloced, and + is the buffer inside PL_rs, so dont free it. */ assert (temp_buffer == rsptr); - temp_buffer = NULL; - goto nope; + goto nope_free_sv; } rsptr = temp_buffer; } @@ -877,16 +873,16 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) } if (rslen == 1) { if (*s != *rsptr) - goto nope; + goto nope_free_all; ++count; } else { if (len < rslen - 1) - goto nope; + goto nope_free_all; len -= rslen - 1; s -= rslen - 1; if (memNE(s, rsptr, rslen)) - goto nope; + goto nope_free_all; count += rs_charlen; } } @@ -895,12 +891,13 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) *SvEND(sv) = '\0'; SvNIOK_off(sv); SvSETMAGIC(sv); - } - nope: - SvREFCNT_dec(svrecode); - - Safefree(temp_buffer); + nope_free_all: + Safefree(temp_buffer); + nope_free_sv: + SvREFCNT_dec(svrecode); + nope_free_nothing: ; + } } else { if (len && (!SvPOK(sv) || SvIsCOW(sv))) s = SvPV_force_nomg(sv, len); @@ -949,7 +946,7 @@ PP(pp_schop) if (chomping) sv_setiv(TARG, count); SETTARG; - RETURN; + return NORMAL; } @@ -980,9 +977,12 @@ PP(pp_undef) RETPUSHUNDEF; } - sv = POPs; + sv = TOPs; if (!sv) - RETPUSHUNDEF; + { + SETs(&PL_sv_undef); + return NORMAL; + } if (SvTHINKFIRST(sv)) sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); @@ -1067,7 +1067,8 @@ PP(pp_undef) SvSETMAGIC(sv); } - RETPUSHUNDEF; + SETs(&PL_sv_undef); + return NORMAL; } @@ -1299,7 +1300,8 @@ PP(pp_multiply) alow = aiv; auvok = TRUE; /* effectively it's a UV now */ } else { - alow = -aiv; /* abs, auvok == false records sign */ + /* abs, auvok == false records sign */ + alow = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); } } if (buvok) { @@ -1310,7 +1312,8 @@ PP(pp_multiply) blow = biv; buvok = TRUE; /* effectively it's a UV now */ } else { - blow = -biv; /* abs, buvok == false records sign */ + /* abs, buvok == false records sign */ + blow = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); } } @@ -1336,6 +1339,10 @@ PP(pp_multiply) /* 2s complement assumption that (UV)-IV_MIN is correct. */ /* -ve result, which could overflow an IV */ SP--; + /* can't negate IV_MIN, but there are aren't two + * integers such that !ahigh && !bhigh, where the + * product equals 0x800....000 */ + assert(product != (UV)IV_MIN); SETi( -(IV)product ); RETURN; } /* else drop to NVs below. */ @@ -1373,7 +1380,8 @@ PP(pp_multiply) /* 2s complement assumption again */ /* -ve result, which could overflow an IV */ SP--; - SETi( -(IV)product_low ); + SETi(product_low == (UV)IV_MIN + ? IV_MIN : -(IV)product_low); RETURN; } /* else drop to NVs below. */ } @@ -1386,7 +1394,17 @@ PP(pp_multiply) NV right = SvNV_nomg(svr); NV left = SvNV_nomg(svl); (void)POPs; +#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16 + { + NV result = left * right; + if (Perl_isinf(result)) { + Zero((U8*)&result + 8, 8, U8); + } + SETn( result ); + } +#else SETn( left * right ); +#endif RETURN; } } @@ -1435,7 +1453,7 @@ PP(pp_divide) right_non_neg = TRUE; /* effectively it's a UV now */ } else { - right = -biv; + right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); } } /* historically undef()/0 gives a "Use of uninitialized value" @@ -1456,7 +1474,7 @@ PP(pp_divide) left_non_neg = TRUE; /* effectively it's a UV now */ } else { - left = -aiv; + left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); } } @@ -1486,7 +1504,7 @@ PP(pp_divide) } /* 2s complement assumption */ if (result <= (UV)IV_MIN) - SETi( -(IV)result ); + SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); else { /* It's exact but too negative for IV. */ SETn( -(NV)result ); @@ -1536,7 +1554,7 @@ PP(pp_modulo) right = biv; right_neg = FALSE; /* effectively it's a UV now */ } else { - right = -biv; + right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv); } } } @@ -1566,7 +1584,7 @@ PP(pp_modulo) left = aiv; left_neg = FALSE; /* effectively it's a UV now */ } else { - left = -aiv; + left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv); } } } @@ -1643,8 +1661,9 @@ PP(pp_repeat) dSP; dATARGET; IV count; SV *sv; + bool infnan = FALSE; - if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { + if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { /* TODO: think of some way of doing list-repeat overloading ??? */ sv = POPs; SvGETMAGIC(sv); @@ -1685,34 +1704,45 @@ PP(pp_repeat) } } else if (SvNOKp(sv)) { - const NV nv = SvNV_nomg(sv); - if (nv < 0.0) - count = -1; /* An arbitrary negative integer */ - else - count = (IV)nv; + const NV nv = SvNV_nomg(sv); + infnan = Perl_isinfnan(nv); + if (UNLIKELY(infnan)) { + count = 0; + } else { + if (nv < 0.0) + count = -1; /* An arbitrary negative integer */ + else + count = (IV)nv; + } } else - count = SvIV_nomg(sv); + count = SvIV_nomg(sv); - if (count < 0) { + if (infnan) { + Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), + "Non-finite repeat count does nothing"); + } else if (count < 0) { count = 0; Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), - "Negative repeat count does nothing"); + "Negative repeat count does nothing"); } - if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { + if (GIMME_V == 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 SSize_t items = SP - MARK; const U8 mod = PL_op->op_flags & OPf_MOD; - MEM_WRAP_CHECK_1(max, SV*, oom_list_extend); - /* Did the max computation overflow? */ - if (items > 0 && max > 0 && (max < items || max < count)) - Perl_croak(aTHX_ "%s", oom_list_extend); - MEXTEND(MARK, max); if (count > 1) { + SSize_t max; + + if ( items > SSize_t_MAX / count /* max would overflow */ + /* repeatcpy would overflow */ + || items > I32_MAX / (I32)sizeof(SV *) + ) + Perl_croak(aTHX_ "%s","Out of memory during list extend"); + max = items * count; + MEXTEND(MARK, max); + while (SP > MARK) { if (*SP) { if (mod && SvPADTMP(*SP)) { @@ -1728,14 +1758,12 @@ PP(pp_repeat) SP += max; } else if (count <= 0) - SP -= items; + SP = MARK; } else { /* Note: mark already snarfed by pp_list */ SV * const tmpstr = POPs; STRLEN len; bool isutf; - static const char* const oom_string_extend = - "Out of memory during string extend"; if (TARG != tmpstr) sv_setsv_nomg(TARG, tmpstr); @@ -1745,11 +1773,16 @@ PP(pp_repeat) if (count < 1) SvCUR_set(TARG, 0); else { - const STRLEN max = (UV)count * len; - if (len > MEM_SIZE_MAX / count) - Perl_croak(aTHX_ "%s", oom_string_extend); - MEM_WRAP_CHECK_1(max, char, oom_string_extend); - SvGROW(TARG, max + 1); + STRLEN max; + + if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */ + || len > (U32)I32_MAX /* repeatcpy would overflow */ + ) + Perl_croak(aTHX_ "%s", + "Out of memory during string extend"); + max = (UV)count * len + 1; + SvGROW(TARG, max); + repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); SvCUR_set(TARG, SvCUR(TARG) * count); } @@ -1798,7 +1831,7 @@ PP(pp_subtract) auv = aiv; auvok = 1; /* Now acting as a sign flag. */ } else { /* 2s complement assumption for IV_MIN */ - auv = (UV)-aiv; + auv = (aiv == IV_MIN) ? (UV)aiv : (UV)-aiv; } } a_valid = 1; @@ -1818,7 +1851,7 @@ PP(pp_subtract) buv = biv; buvok = 1; } else - buv = (UV)-biv; + buv = (biv == IV_MIN) ? (UV)biv : (UV)-biv; } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, else "IV" now, independent of how it came in. @@ -1859,7 +1892,8 @@ PP(pp_subtract) else { /* Negate result */ if (result <= (UV)IV_MIN) - SETi( -(IV)result ); + SETi(result == (UV)IV_MIN + ? IV_MIN : -(IV)result); else { /* result valid, but out of range for IV. */ SETn( -(NV)result ); @@ -1884,6 +1918,37 @@ PP(pp_subtract) } } +#define IV_BITS (IVSIZE * 8) + +static UV S_uv_shift(UV uv, int shift, bool left) +{ + if (shift < 0) { + shift = -shift; + left = !left; + } + if (shift >= IV_BITS) { + return 0; + } + return left ? uv << shift : uv >> shift; +} + +static IV S_iv_shift(IV iv, int shift, bool left) +{ + if (shift < 0) { + shift = -shift; + left = !left; + } + if (shift >= IV_BITS) { + return iv < 0 && !left ? -1 : 0; + } + return left ? iv << shift : iv >> shift; +} + +#define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE) +#define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE) +#define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE) +#define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE) + PP(pp_left_shift) { dSP; dATARGET; SV *svl, *svr; @@ -1893,12 +1958,10 @@ PP(pp_left_shift) { const IV shift = SvIV_nomg(svr); if (PL_op->op_private & HINT_INTEGER) { - const IV i = SvIV_nomg(svl); - SETi(i << shift); + SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift)); } else { - const UV u = SvUV_nomg(svl); - SETu(u << shift); + SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift)); } RETURN; } @@ -1913,12 +1976,10 @@ PP(pp_right_shift) { const IV shift = SvIV_nomg(svr); if (PL_op->op_private & HINT_INTEGER) { - const IV i = SvIV_nomg(svl); - SETi(i >> shift); + SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift)); } else { - const UV u = SvUV_nomg(svl); - SETu(u >> shift); + SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift)); } RETURN; } @@ -2208,6 +2269,34 @@ PP(pp_bit_and) } } +PP(pp_nbit_and) +{ + dSP; + tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg); + { + dATARGET; dPOPTOPssrl; + if (PL_op->op_private & HINT_INTEGER) { + const IV i = SvIV_nomg(left) & SvIV_nomg(right); + SETi(i); + } + else { + const UV u = SvUV_nomg(left) & SvUV_nomg(right); + SETu(u); + } + } + RETURN; +} + +PP(pp_sbit_and) +{ + dSP; + tryAMAGICbin_MG(sband_amg, AMGf_assign); + { + dATARGET; dPOPTOPssrl; + do_vop(OP_BIT_AND, TARG, left, right); + RETSETTARG; + } +} /* also used for: pp_bit_xor() */ @@ -2245,6 +2334,50 @@ PP(pp_bit_or) } } +/* also used for: pp_nbit_xor() */ + +PP(pp_nbit_or) +{ + dSP; + const int op_type = PL_op->op_type; + + tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg), + AMGf_assign|AMGf_numarg); + { + dATARGET; dPOPTOPssrl; + if (PL_op->op_private & HINT_INTEGER) { + const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); + const IV r = SvIV_nomg(right); + const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); + SETi(result); + } + else { + const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0); + const UV r = SvUV_nomg(right); + const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r); + SETu(result); + } + } + RETURN; +} + +/* also used for: pp_sbit_xor() */ + +PP(pp_sbit_or) +{ + dSP; + const int op_type = PL_op->op_type; + + tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg), + AMGf_assign); + { + dATARGET; dPOPTOPssrl; + do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left, + right); + RETSETTARG; + } +} + PERL_STATIC_INLINE bool S_negate_string(pTHX) { @@ -2264,7 +2397,7 @@ S_negate_string(pTHX) *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; } else return FALSE; - SETTARG; PUTBACK; + SETTARG; return TRUE; } @@ -2284,21 +2417,21 @@ PP(pp_negate) /* 2s complement assumption. */ SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ - RETURN; + return NORMAL; } else if (SvUVX(sv) <= IV_MAX) { SETi(-SvIVX(sv)); - RETURN; + return NORMAL; } } else if (SvIVX(sv) != IV_MIN) { SETi(-SvIVX(sv)); - RETURN; + return NORMAL; } #ifdef PERL_PRESERVE_IVUV else { SETu((UV)IV_MIN); - RETURN; + return NORMAL; } #endif } @@ -2309,7 +2442,7 @@ PP(pp_negate) else SETn(-SvNV_nomg(sv)); } - RETURN; + return NORMAL; } PP(pp_not) @@ -2320,23 +2453,9 @@ PP(pp_not) return NORMAL; } -PP(pp_complement) +static void +S_scomplement(pTHX_ SV *targ, SV *sv) { - dSP; dTARGET; - tryAMAGICun_MG(compl_amg, AMGf_numeric); - { - dTOPss; - if (SvNIOKp(sv)) { - if (PL_op->op_private & HINT_INTEGER) { - const IV i = ~SvIV_nomg(sv); - SETi(i); - } - else { - const UV u = ~SvUV_nomg(sv); - SETu(u); - } - } - else { U8 *tmps; I32 anum; STRLEN len; @@ -2357,7 +2476,7 @@ PP(pp_complement) while (tmps < send) { const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags); tmps += l; - targlen += UNISKIP(~c); + targlen += UVCHR_SKIP(~c); nchar++; if (c > 0xff) nwide++; @@ -2397,8 +2516,7 @@ PP(pp_complement) sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL); SvUTF8_off(TARG); } - SETTARG; - RETURN; + return; } #ifdef LIBERAL { @@ -2413,9 +2531,59 @@ PP(pp_complement) #endif for ( ; anum > 0; anum--, tmps++) *tmps = ~*tmps; +} + +PP(pp_complement) +{ + dSP; dTARGET; + tryAMAGICun_MG(compl_amg, AMGf_numeric); + { + dTOPss; + if (SvNIOKp(sv)) { + if (PL_op->op_private & HINT_INTEGER) { + const IV i = ~SvIV_nomg(sv); + SETi(i); + } + else { + const UV u = ~SvUV_nomg(sv); + SETu(u); + } + } + else { + S_scomplement(aTHX_ TARG, sv); SETTARG; } - RETURN; + return NORMAL; + } +} + +PP(pp_ncomplement) +{ + dSP; + tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg); + { + dTARGET; dTOPss; + if (PL_op->op_private & HINT_INTEGER) { + const IV i = ~SvIV_nomg(sv); + SETi(i); + } + else { + const UV u = ~SvUV_nomg(sv); + SETu(u); + } + } + return NORMAL; +} + +PP(pp_scomplement) +{ + dSP; + tryAMAGICun_MG(scompl_amg, AMGf_numeric); + { + dTARGET; dTOPss; + S_scomplement(aTHX_ TARG, sv); + SETTARG; + return NORMAL; } } @@ -2454,7 +2622,8 @@ PP(pp_i_divide) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) +#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ + && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) STATIC PP(pp_i_modulo_0) #else @@ -2477,7 +2646,8 @@ PP(pp_i_modulo) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) +#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ + && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) STATIC PP(pp_i_modulo_1) @@ -2513,7 +2683,7 @@ PP(pp_i_modulo) PL_ppaddr[OP_I_MODULO] = Perl_pp_i_modulo_0; /* .. but if we have glibc, we might have a buggy _moddi3 - * (at least glicb 2.2.5 is known to have this bug), in other + * (at least glibc 2.2.5 is known to have this bug), in other * words our integer modulus with negative quad as the second * argument might be broken. Test for this and re-patch the * opcode dispatch table if that is the case, remembering to @@ -2660,7 +2830,7 @@ PP(pp_i_negate) SV * const sv = TOPs; IV const i = SvIV_nomg(sv); SETi(-i); - RETURN; + return NORMAL; } } @@ -2699,7 +2869,7 @@ PP(pp_sin) tryAMAGICun_MG(amg_type, 0); { - SV * const arg = POPs; + SV * const arg = TOPs; const NV value = SvNV_nomg(arg); NV result = NV_NAN; if (neg_report) { /* log or sqrt */ @@ -2721,8 +2891,8 @@ PP(pp_sin) case OP_LOG: result = Perl_log(value); break; case OP_SQRT: result = Perl_sqrt(value); break; } - XPUSHn(result); - RETURN; + SETn(result); + return NORMAL; } } @@ -2746,10 +2916,12 @@ PP(pp_rand) { dSP; NV value; - EXTEND(SP, 1); if (MAXARG < 1) + { + EXTEND(SP, 1); value = 1.0; + } else { SV * const sv = POPs; if(!sv) @@ -2836,8 +3008,8 @@ PP(pp_int) } else { const NV value = SvNV_nomg(sv); - if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv)))) - SETn(SvNV(sv)); + if (UNLIKELY(Perl_isinfnan(value))) + SETn(value); else if (value >= 0.0) { if (value < (NV)UV_MAX + 0.5) { SETu(U_V(value)); @@ -2854,7 +3026,7 @@ PP(pp_int) } } } - RETURN; + return NORMAL; } PP(pp_abs) @@ -2894,7 +3066,7 @@ PP(pp_abs) SETn(value); } } - RETURN; + return NORMAL; } @@ -2908,7 +3080,7 @@ PP(pp_oct) STRLEN len; NV result_nv; UV result_uv; - SV* const sv = POPs; + SV* const sv = TOPs; tmps = (SvPV_const(sv, len)); if (DO_UTF8(sv)) { @@ -2937,12 +3109,12 @@ PP(pp_oct) result_uv = grok_oct (tmps, &len, &flags, &result_nv); if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { - XPUSHn(result_nv); + SETn(result_nv); } else { - XPUSHu(result_uv); + SETu(result_uv); } - RETURN; + return NORMAL; } /* String stuff. */ @@ -3099,7 +3271,6 @@ PP(pp_substr) assert(!repl_sv); repl_sv = POPs; } - PUTBACK; if (lvalue && !repl_sv) { SV * ret; ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ @@ -3115,7 +3286,6 @@ PP(pp_substr) ? (STRLEN)(UV)len_iv : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv); - SPAGAIN; PUSHs(ret); /* avoid SvSETMAGIC here */ RETURN; } @@ -3185,7 +3355,6 @@ PP(pp_substr) SvREFCNT_dec(repl_sv_copy); } } - SPAGAIN; if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) SP++; else if (rvalue) { @@ -3194,7 +3363,7 @@ PP(pp_substr) } RETURN; -bound_fail: + bound_fail: if (repl) Perl_croak(aTHX_ "substr outside of string"); Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); @@ -3314,7 +3483,7 @@ PP(pp_index) SvPV_const some lines above. We can't remove that, as we need to call some SvPV to trigger overloading early and find out if the string is UTF-8. - This is all getting to messy. The API isn't quite clean enough, + This is all getting too messy. The API isn't quite clean enough, because data access has side effects. */ little = newSVpvn_flags(little_p, llen, @@ -3342,7 +3511,7 @@ PP(pp_index) retval = -1; else { retval = little_p - big_p; - if (retval > 0 && big_utf8) + if (retval > 1 && big_utf8) retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); } SvREFCNT_dec(temp); @@ -3366,7 +3535,7 @@ PP(pp_ord) { dSP; dTARGET; - SV *argsv = POPs; + SV *argsv = TOPs; STRLEN len; const U8 *s = (U8*)SvPV_const(argsv, len); @@ -3377,11 +3546,11 @@ PP(pp_ord) argsv = tmpsv; } - XPUSHu(DO_UTF8(argsv) + SETu(DO_UTF8(argsv) ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : (UV)(*s)); - RETURN; + return NORMAL; } PP(pp_chr) @@ -3389,9 +3558,11 @@ PP(pp_chr) dSP; dTARGET; char *tmps; UV value; - SV *top = POPs; + SV *top = TOPs; SvGETMAGIC(top); + if (UNLIKELY(SvAMAGIC(top))) + top = sv_2num(top); if (UNLIKELY(isinfnansv(top))) Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top)); else { @@ -3399,7 +3570,8 @@ PP(pp_chr) && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) || ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) - && SvNV_nomg(top) < 0.0))) { + && SvNV_nomg(top) < 0.0))) + { if (ckWARN(WARN_UTF8)) { if (SvGMAGICAL(top)) { SV *top2 = sv_newmortal(); @@ -3418,14 +3590,14 @@ PP(pp_chr) SvUPGRADE(TARG,SVt_PV); if (value > 255 && !IN_BYTES) { - SvGROW(TARG, (STRLEN)UNISKIP(value)+1); + SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1); tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); SvCUR_set(TARG, tmps - SvPVX_const(TARG)); *tmps = '\0'; (void)SvPOK_only(TARG); SvUTF8_on(TARG); - XPUSHTARG; - RETURN; + SETTARG; + return NORMAL; } SvGROW(TARG,2); @@ -3451,8 +3623,8 @@ PP(pp_chr) } } - XPUSHTARG; - RETURN; + SETTARG; + return NORMAL; } PP(pp_crypt) @@ -3586,23 +3758,27 @@ PP(pp_ucfirst) if (op_type == OP_LCFIRST) { /* lower case the first letter: no trickiness for any character */ - *tmpbuf = #ifdef USE_LOCALE_CTYPE - (IN_LC_RUNTIME(LC_CTYPE)) - ? toLOWER_LC(*s) - : + if (IN_LC_RUNTIME(LC_CTYPE)) { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + *tmpbuf = toLOWER_LC(*s); + } + else #endif - (IN_UNI_8_BIT) - ? toLOWER_LATIN1(*s) - : toLOWER(*s); + { + *tmpbuf = (IN_UNI_8_BIT) + ? toLOWER_LATIN1(*s) + : toLOWER(*s); + } } - /* is ucfirst() */ #ifdef USE_LOCALE_CTYPE + /* is ucfirst() */ else if (IN_LC_RUNTIME(LC_CTYPE)) { if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_rules; } + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any locales have upper and title case different */ @@ -3761,7 +3937,7 @@ PP(pp_ucfirst) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } /* There's so much setup/teardown code common between uc and lc, I wonder if @@ -3907,6 +4083,7 @@ PP(pp_uc) if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_rules; } + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = (U8) toUPPER_LC(*s); } @@ -3933,6 +4110,9 @@ PP(pp_uc) * just above. * Use the source to distinguish between the three cases */ +#if UNICODE_MAJOR_VERSION > 2 \ + || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ + && UNICODE_DOT_DOT_VERSION >= 8) if (*s == LATIN_SMALL_LETTER_SHARP_S) { /* uc() of this requires 2 characters, but they are @@ -3945,6 +4125,7 @@ PP(pp_uc) *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */ continue; /* Back to the tight loop; still in ASCII */ } +#endif /* The other two special handling characters have their * upper cases outside the latin1 range, hence need to be @@ -4018,7 +4199,7 @@ PP(pp_uc) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } PP(pp_lc) @@ -4114,6 +4295,7 @@ PP(pp_lc) * whole thing in a tight loop, for speed, */ #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = toLOWER_LC(*s); } @@ -4144,7 +4326,7 @@ PP(pp_lc) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } PP(pp_quotemeta) @@ -4179,7 +4361,7 @@ PP(pp_quotemeta) IN_LC_RUNTIME(LC_CTYPE) || #endif - _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1)))) + _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1)))) { to_quote = TRUE; } @@ -4222,7 +4404,7 @@ PP(pp_quotemeta) else sv_setpvn(TARG, s, len); SETTARG; - RETURN; + return NORMAL; } PP(pp_fc) @@ -4237,8 +4419,14 @@ PP(pp_fc) const U8 *send; U8 *d; U8 tmpbuf[UTF8_MAXBYTES_CASE + 1]; +#if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ + || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ + || UNICODE_DOT_DOT_VERSION > 0) const bool full_folding = TRUE; /* This variable is here so we can easily move to more generality later */ +#else + const bool full_folding = FALSE; +#endif const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 ) #ifdef USE_LOCALE_CTYPE | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 ) @@ -4296,6 +4484,7 @@ PP(pp_fc) if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_folding; } + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = (U8) toFOLD_LC(*s); } @@ -4445,7 +4634,7 @@ PP(pp_aslice) *MARK = svp ? *svp : &PL_sv_undef; } } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = ORIGMARK; *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; SP = MARK; @@ -4490,7 +4679,7 @@ PP(pp_kvaslice) } *++MARK = svp ? *svp : &PL_sv_undef; } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = SP - items*2; *++MARK = items > 0 ? *SP : &PL_sv_undef; SP = MARK; @@ -4499,47 +4688,6 @@ PP(pp_kvaslice) } -/* Smart dereferencing for keys, values and each */ - -/* also used for: pp_reach() pp_rvalues() */ - -PP(pp_rkeys) -{ - dSP; - dPOPss; - - SvGETMAGIC(sv); - - if ( - !SvROK(sv) - || (sv = SvRV(sv), - (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV) - || SvOBJECT(sv) - ) - ) { - DIE(aTHX_ - "Type of argument to %s must be unblessed hashref or arrayref", - PL_op_desc[PL_op->op_type] ); - } - - if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV) - DIE(aTHX_ - "Can't modify %s in %s", - PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type] - ); - - /* Delegate to correct function for op type */ - PUSHs(sv); - if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) { - return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX); - } - else { - return (SvTYPE(sv) == SVt_PVHV) - ? Perl_pp_each(aTHX) - : Perl_pp_aeach(aTHX); - } -} - PP(pp_aeach) { dSP; @@ -4584,7 +4732,7 @@ PP(pp_akeys) EXTEND(SP, n + 1); - if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) { + if (PL_op->op_type == OP_AKEYS) { for (i = 0; i <= n; i++) { mPUSHi(i); } @@ -4608,21 +4756,15 @@ PP(pp_each) HE *entry; const I32 gimme = GIMME_V; - PUTBACK; - /* might clobber stack_sp */ entry = hv_iternext(hash); - SPAGAIN; EXTEND(SP, 2); if (entry) { SV* const sv = hv_iterkeysv(entry); - PUSHs(sv); /* won't clobber stack_sp */ + PUSHs(sv); if (gimme == G_ARRAY) { SV *val; - PUTBACK; - /* might clobber stack_sp */ val = hv_iterval(hash, entry); - SPAGAIN; PUSHs(val); } } @@ -4891,7 +5033,7 @@ PP(pp_hslice) } *MARK = svp && *svp ? *svp : &PL_sv_undef; } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = ORIGMARK; *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; SP = MARK; @@ -4940,7 +5082,7 @@ PP(pp_kvhslice) } *++MARK = svp && *svp ? *svp : &PL_sv_undef; } - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { MARK = SP - items*2; *++MARK = items > 0 ? *SP : &PL_sv_undef; SP = MARK; @@ -4953,7 +5095,7 @@ PP(pp_kvhslice) PP(pp_list) { I32 markidx = POPMARK; - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { SV **mark = PL_stack_base + markidx; dSP; if (++MARK <= SP) @@ -4973,13 +5115,12 @@ PP(pp_lslice) 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; - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { I32 ix = SvIV(*lastlelem); if (ix < 0) ix += max; @@ -5003,7 +5144,6 @@ PP(pp_lslice) if (ix < 0 || ix >= max) *lelem = &PL_sv_undef; else { - is_something_there = TRUE; if (!(*lelem = firstrelem[ix])) *lelem = &PL_sv_undef; else if (mod && SvPADTMP(*lelem)) { @@ -5011,10 +5151,7 @@ PP(pp_lslice) } } } - if (is_something_there) - SP = lastlelem; - else - SP = firstlelem - 1; + SP = lastlelem; RETURN; } @@ -5046,7 +5183,7 @@ PP(pp_anonhash) MARK++; SvGETMAGIC(*MARK); val = newSV(0); - sv_setsv(val, *MARK); + sv_setsv_nomg(val, *MARK); } else { @@ -5168,7 +5305,7 @@ PP(pp_splice) } MARK = ORIGMARK + 1; - if (GIMME == G_ARRAY) { /* copy return vals to stack */ + if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ const bool real = cBOOL(AvREAL(ary)); MEXTEND(MARK, length); if (real) @@ -5264,7 +5401,7 @@ PP(pp_splice) } MARK = ORIGMARK + 1; - if (GIMME == G_ARRAY) { /* copy return vals to stack */ + if (GIMME_V == G_ARRAY) { /* copy return vals to stack */ if (length) { const bool real = cBOOL(AvREAL(ary)); if (real) @@ -5313,9 +5450,13 @@ PP(pp_push) ENTER_with_name("call_PUSH"); call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED); LEAVE_with_name("call_PUSH"); - SPAGAIN; + /* SPAGAIN; not needed: SP is assigned to immediately below */ } else { + /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we + * only need to save locally, not on the save stack */ + U16 old_delaymagic = PL_delaymagic; + if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify(); PL_delaymagic = DM_DELAY; for (++MARK; MARK <= SP; MARK++) { @@ -5328,8 +5469,7 @@ PP(pp_push) } if (PL_delaymagic & DM_ARRAY_ISA) mg_set(MUTABLE_SV(ary)); - - PL_delaymagic = 0; + PL_delaymagic = old_delaymagic; } SP = ORIGMARK; if (OP_GIMME(PL_op, 0) != G_VOID) { @@ -5366,15 +5506,23 @@ PP(pp_unshift) ENTER_with_name("call_UNSHIFT"); call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED); LEAVE_with_name("call_UNSHIFT"); - SPAGAIN; + /* SPAGAIN; not needed: SP is assigned to immediately below */ } else { + /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we + * only need to save locally, not on the save stack */ + U16 old_delaymagic = PL_delaymagic; SSize_t i = 0; + av_unshift(ary, SP - MARK); + PL_delaymagic = DM_DELAY; while (MARK < SP) { SV * const sv = newSVsv(*++MARK); (void)av_store(ary, i++, sv); } + if (PL_delaymagic & DM_ARRAY_ISA) + mg_set(MUTABLE_SV(ary)); + PL_delaymagic = old_delaymagic; } SP = ORIGMARK; if (OP_GIMME(PL_op, 0) != G_VOID) { @@ -5387,7 +5535,7 @@ PP(pp_reverse) { dSP; dMARK; - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { if (PL_op->op_private & OPpREVERSE_INPLACE) { AV *av; @@ -5471,7 +5619,7 @@ PP(pp_reverse) if (SP - MARK > 1) do_join(TARG, &PL_sv_no, MARK, SP); else { - sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv()); + sv_setsv(TARG, SP > MARK ? *SP : DEFSV); } up = SvPV_force(TARG, len); @@ -5535,7 +5683,7 @@ PP(pp_split) SSize_t maxiters = slen + 10; I32 trailing_empty = 0; const char *orig; - const I32 origlimit = limit; + const IV origlimit = limit; I32 realarray = 0; I32 base; const I32 gimme = GIMME_V; @@ -5560,15 +5708,18 @@ PP(pp_split) #ifdef USE_ITHREADS if (pm->op_pmreplrootu.op_pmtargetoff) { ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff))); + goto have_av; } #else if (pm->op_pmreplrootu.op_pmtargetgv) { ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv); + goto have_av; } #endif else if (pm->op_targ) ary = (AV *)PAD_SVl(pm->op_targ); if (ary) { + have_av: realarray = 1; PUTBACK; av_extend(ary,0); @@ -5706,11 +5857,13 @@ PP(pp_split) split //, $str, $i; */ if (!gimme_scalar) { - const U32 items = limit - 1; - if (items < slen) + const IV items = limit - 1; + /* setting it to -1 will trigger a panic in EXTEND() */ + const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen; + if (items >=0 && items < sslen) EXTEND(SP, items); else - EXTEND(SP, slen); + EXTEND(SP, sslen); } if (do_utf8) { @@ -6055,10 +6208,7 @@ PP(pp_coreargs) case OA_SCALAR: try_defsv: if (!numargs && defgv && whicharg == minargs + 1) { - PUSHs(find_rundefsv2( - find_runcv_where(FIND_RUNCV_level_eq, 1, NULL), - cxstack[cxstack_ix].blk_oldcop->cop_seq - )); + PUSHs(DEFSV); } else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL); break; @@ -6251,6 +6401,7 @@ PP(pp_refassign) SvSETMAGIC(left); break; case SVt_PVAV: + assert(key); if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { S_localise_aelem_lval(aTHX_ (AV *)left, key, SvCANEXISTDELETE(left)); @@ -6258,9 +6409,11 @@ PP(pp_refassign) av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv))); break; case SVt_PVHV: - if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) + if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { + assert(key); S_localise_helem_lval(aTHX_ (HV *)left, key, SvCANEXISTDELETE(left)); + } (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); } if (PL_op->op_flags & OPf_MOD) @@ -6285,13 +6438,16 @@ PP(pp_lvref) mg->mg_flags |= MGf_PERSIST; if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) { if (elem) { - MAGIC *mg; - HV *stash; - const bool can_preserve = SvCANEXISTDELETE(arg); - if (SvTYPE(arg) == SVt_PVAV) - S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve); - else - S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve); + MAGIC *mg; + HV *stash; + assert(arg); + { + const bool can_preserve = SvCANEXISTDELETE(arg); + if (SvTYPE(arg) == SVt_PVAV) + S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve); + else + S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve); + } } else if (arg) { S_localise_gv_slot(aTHX_ (GV *)arg, @@ -6358,12 +6514,17 @@ PP(pp_lvavref) } } +PP(pp_anonconst) +{ + dSP; + dTOPss; + SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV + ? CopSTASH(PL_curcop) + : NULL, + NULL, SvREFCNT_inc_simple_NN(sv)))); + RETURN; +} + /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */