X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/821f14b05f7c61652c204d445e24dff53e6f64ab..25e3a4e08a8b645de44458470ff4f139baf56682:/pp.c?ds=sidebyside diff --git a/pp.c b/pp.c index 08ca123..ea49b01 100644 --- a/pp.c +++ b/pp.c @@ -66,40 +66,43 @@ PP(pp_stub) PP(pp_padav) { dSP; dTARGET; - I32 gimme; + U8 gimme; assert(SvTYPE(TARG) == SVt_PVAV); 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) { PUSHs(TARG); RETURN; - } else if (PL_op->op_private & OPpMAYBE_LVSUB) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) { - 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); - RETURN; + } + else if (PL_op->op_private & OPpMAYBE_LVSUB) { + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { + 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); + RETURN; } } + 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; } @@ -118,24 +121,26 @@ PP(pp_padav) PP(pp_padhv) { dSP; dTARGET; - I32 gimme; + U8 gimme; assert(SvTYPE(TARG) == SVt_PVHV); XPUSHs(TARG); 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; else if (PL_op->op_private & OPpMAYBE_LVSUB) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) { - 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; - } + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { + 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; + } } + gimme = GIMME_V; if (gimme == G_ARRAY) { RETURNOP(Perl_do_kv(aTHX)); @@ -143,7 +148,8 @@ PP(pp_padhv) else if ((PL_op->op_private & OPpTRUEBOOL || ( PL_op->op_private & OPpMAYBE_TRUEBOOL && block_gimme() == G_VOID )) - && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))) + && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)) + ) SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0))); else if (gimme == G_SCALAR) { SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG)); @@ -669,8 +675,6 @@ PP(pp_gelem) break; case 'F': if (len == 10 && strEQ(second_letter, "ILEHANDLE")) { - /* finally deprecated in 5.8.0 */ - deprecate("*glob{FILEHANDLE}"); tmpRef = MUTABLE_SV(GvIOp(gv)); } else @@ -762,7 +766,8 @@ PP(pp_trans) PUSHs(newsv); } else { - mPUSHi(do_trans(sv)); + I32 i = do_trans(sv); + mPUSHi(i); } RETURN; } @@ -804,27 +809,15 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) Perl_croak_no_modify(); } - if (IN_ENCODING) { - if (!SvUTF8(sv)) { - /* XXX, here sv is utf8-ized as a side-effect! - If encoding.pm is used properly, almost string-generating - operations, including literal strings, chr(), input data, etc. - should have been utf8-ized already, right? - */ - sv_recode_to_utf8(sv, _get_encoding()); - } - } - 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; @@ -848,22 +841,15 @@ 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; } - else if (IN_ENCODING) { - /* RS is 8 bit, encoding.pm is used. - * Do not recode PL_rs as a side-effect. */ - svrecode = newSVpvn(rsptr, rslen); - sv_recode_to_utf8(svrecode, _get_encoding()); - rsptr = SvPV_const(svrecode, rslen); - rs_charlen = sv_len_utf8(svrecode); - } else { /* RS is 8 bit, scalar is utf8. */ temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen); @@ -872,16 +858,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; } } @@ -890,12 +876,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); @@ -1070,28 +1057,23 @@ PP(pp_undef) } -/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */ +/* common "slow" code for pp_postinc and pp_postdec */ -PP(pp_postinc) +static OP * +S_postincdec_common(pTHX_ SV *sv, SV *targ) { - dSP; dTARGET; + dSP; 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))) - Perl_croak_no_modify(); - if (SvROK(TOPs)) + + if (SvROK(sv)) TARG = sv_newmortal(); - sv_setsv(TARG, TOPs); - if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) - && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN)) - { - SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1)); - SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); - } - else if (inc) - sv_inc_nomg(TOPs); - else sv_dec_nomg(TOPs); - SvSETMAGIC(TOPs); + sv_setsv(TARG, sv); + if (inc) + sv_inc_nomg(sv); + else + sv_dec_nomg(sv); + SvSETMAGIC(sv); /* special case for undef: see thread at 2003-03/msg00536.html in archive */ if (inc && !SvOK(TARG)) sv_setiv(TARG, 0); @@ -1099,6 +1081,57 @@ PP(pp_postinc) return NORMAL; } + +/* also used for: pp_i_postinc() */ + +PP(pp_postinc) +{ + dSP; dTARGET; + SV *sv = TOPs; + + /* special-case sv being a simple integer */ + if (LIKELY(((sv->sv_flags & + (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| + SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) + == SVf_IOK)) + && SvIVX(sv) != IV_MAX) + { + IV iv = SvIVX(sv); + SvIV_set(sv, iv + 1); + TARGi(iv, 0); /* arg not GMG, so can't be tainted */ + SETs(TARG); + return NORMAL; + } + + return S_postincdec_common(aTHX_ sv, TARG); +} + + +/* also used for: pp_i_postdec() */ + +PP(pp_postdec) +{ + dSP; dTARGET; + SV *sv = TOPs; + + /* special-case sv being a simple integer */ + if (LIKELY(((sv->sv_flags & + (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV| + SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK)) + == SVf_IOK)) + && SvIVX(sv) != IV_MIN) + { + IV iv = SvIVX(sv); + SvIV_set(sv, iv - 1); + TARGi(iv, 0); /* arg not GMG, so can't be tainted */ + SETs(TARG); + return NORMAL; + } + + return S_postincdec_common(aTHX_ sv, TARG); +} + + /* Ordinary operators. */ PP(pp_pow) @@ -1274,7 +1307,69 @@ PP(pp_multiply) tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; + #ifdef PERL_PRESERVE_IVUV + + /* special-case some simple common cases */ + if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) { + IV il, ir; + U32 flags = (svl->sv_flags & svr->sv_flags); + if (flags & SVf_IOK) { + /* both args are simple IVs */ + UV topl, topr; + il = SvIVX(svl); + ir = SvIVX(svr); + do_iv: + topl = ((UV)il) >> (UVSIZE * 4 - 1); + topr = ((UV)ir) >> (UVSIZE * 4 - 1); + + /* if both are in a range that can't under/overflow, do a + * simple integer multiply: if the top halves(*) of both numbers + * are 00...00 or 11...11, then it's safe. + * (*) for 32-bits, the "top half" is the top 17 bits, + * for 64-bits, its 33 bits */ + if (!( + ((topl+1) | (topr+1)) + & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */ + )) { + SP--; + TARGi(il * ir, 0); /* args not GMG, so can't be tainted */ + SETs(TARG); + RETURN; + } + goto generic; + } + else if (flags & SVf_NOK) { + /* both args are NVs */ + NV nl = SvNVX(svl); + NV nr = SvNVX(svr); + NV result; + + if ( +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) + && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) +#else + nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) +#endif + ) + /* nothing was lost by converting to IVs */ + goto do_iv; + SP--; + result = nl * nr; +# if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16 + if (Perl_isinf(result)) { + Zero((U8*)&result + 8, 8, U8); + } +# endif + TARGn(result, 0); /* args not GMG, so can't be tainted */ + SETs(TARG); + RETURN; + } + } + + generic: + if (SvIV_please_nomg(svr)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if @@ -1298,7 +1393,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) { @@ -1309,7 +1405,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); } } @@ -1335,6 +1432,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. */ @@ -1372,7 +1473,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. */ } @@ -1384,8 +1486,15 @@ PP(pp_multiply) { NV right = SvNV_nomg(svr); NV left = SvNV_nomg(svl); + NV result = left * right; + (void)POPs; - SETn( left * right ); +#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16 + if (Perl_isinf(result)) { + Zero((U8*)&result + 8, 8, U8); + } +#endif + SETn(result); RETURN; } } @@ -1434,7 +1543,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" @@ -1455,7 +1564,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); } } @@ -1485,7 +1594,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 ); @@ -1535,7 +1644,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); } } } @@ -1565,7 +1674,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); } } } @@ -1642,6 +1751,7 @@ PP(pp_repeat) dSP; dATARGET; IV count; SV *sv; + bool infnan = FALSE; if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { /* TODO: think of some way of doing list-repeat overloading ??? */ @@ -1684,34 +1794,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_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)) { @@ -1727,14 +1848,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); @@ -1744,11 +1863,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); } @@ -1770,8 +1894,58 @@ PP(pp_subtract) tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; - useleft = USE_LEFT(svl); + #ifdef PERL_PRESERVE_IVUV + + /* special-case some simple common cases */ + if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) { + IV il, ir; + U32 flags = (svl->sv_flags & svr->sv_flags); + if (flags & SVf_IOK) { + /* both args are simple IVs */ + UV topl, topr; + il = SvIVX(svl); + ir = SvIVX(svr); + do_iv: + topl = ((UV)il) >> (UVSIZE * 8 - 2); + topr = ((UV)ir) >> (UVSIZE * 8 - 2); + + /* if both are in a range that can't under/overflow, do a + * simple integer subtract: if the top of both numbers + * are 00 or 11, then it's safe */ + if (!( ((topl+1) | (topr+1)) & 2)) { + SP--; + TARGi(il - ir, 0); /* args not GMG, so can't be tainted */ + SETs(TARG); + RETURN; + } + goto generic; + } + else if (flags & SVf_NOK) { + /* both args are NVs */ + NV nl = SvNVX(svl); + NV nr = SvNVX(svr); + + if ( +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + !Perl_isnan(nl) && nl == (NV)(il = (IV)nl) + && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr) +#else + nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr) +#endif + ) + /* nothing was lost by converting to IVs */ + goto do_iv; + SP--; + TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */ + SETs(TARG); + RETURN; + } + } + + generic: + + useleft = USE_LEFT(svl); /* See comments in pp_add (in pp_hot.c) about Overflow, and how "bad things" happen if you rely on signed integers wrapping. */ if (SvIV_please_nomg(svr)) { @@ -1797,7 +1971,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; @@ -1817,7 +1991,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. @@ -1858,7 +2032,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 ); @@ -1868,6 +2043,8 @@ PP(pp_subtract) } /* Overflow, drop through to NVs. */ } } +#else + useleft = USE_LEFT(svl); #endif { NV value = SvNV_nomg(svr); @@ -1883,6 +2060,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; @@ -1892,12 +2100,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; } @@ -1912,12 +2118,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; } @@ -2207,6 +2411,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() */ @@ -2244,6 +2476,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) { @@ -2263,7 +2539,7 @@ S_negate_string(pTHX) *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; } else return FALSE; - SETTARG; PUTBACK; + SETTARG; return TRUE; } @@ -2283,21 +2559,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 } @@ -2308,7 +2584,7 @@ PP(pp_negate) else SETn(-SvNV_nomg(sv)); } - RETURN; + return NORMAL; } PP(pp_not) @@ -2319,23 +2595,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; @@ -2356,7 +2618,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++; @@ -2369,6 +2631,8 @@ PP(pp_complement) U8 *result; U8 *p; + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]); Newx(result, targlen + 1, U8); p = result; while (tmps < send) { @@ -2396,8 +2660,7 @@ PP(pp_complement) sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL); SvUTF8_off(TARG); } - SETTARG; - RETURN; + return; } #ifdef LIBERAL { @@ -2412,9 +2675,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; } } @@ -2453,13 +2766,7 @@ PP(pp_i_divide) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ - && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) -STATIC -PP(pp_i_modulo_0) -#else PP(pp_i_modulo) -#endif { /* This is the vanilla old i_modulo. */ dSP; dATARGET; @@ -2477,11 +2784,10 @@ PP(pp_i_modulo) } } -#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \ +#if defined(__GLIBC__) && IVSIZE == 8 \ && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) -STATIC -PP(pp_i_modulo_1) +PP(pp_i_modulo_glibc_bugfix) { /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). @@ -2500,49 +2806,6 @@ PP(pp_i_modulo_1) RETURN; } } - -PP(pp_i_modulo) -{ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(modulo_amg, AMGf_assign); - { - dPOPTOPiirl_nomg; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - /* The assumption is to use hereafter the old vanilla version... */ - PL_op->op_ppaddr = - PL_ppaddr[OP_I_MODULO] = - Perl_pp_i_modulo_0; - /* .. but if we have glibc, we might have a buggy _moddi3 - * (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 - * also apply the workaround so that this first round works - * right, too. See [perl #9402] for more information. */ - { - IV l = 3; - IV r = -10; - /* Cannot do this check with inlined IV constants since - * that seems to work correctly even with the buggy glibc. */ - if (l % r == -3) { - /* Yikes, we have the bug. - * Patch in the workaround version. */ - PL_op->op_ppaddr = - PL_ppaddr[OP_I_MODULO] = - &Perl_pp_i_modulo_1; - /* Make certain we work right this time, too. */ - right = PERL_ABS(right); - } - } - /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ - if (right == -1) - SETi( 0 ); - else - SETi( left % right ); - RETURN; - } -} #endif PP(pp_i_add) @@ -2661,7 +2924,7 @@ PP(pp_i_negate) SV * const sv = TOPs; IV const i = SvIV_nomg(sv); SETi(-i); - RETURN; + return NORMAL; } } @@ -2700,7 +2963,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 */ @@ -2722,8 +2985,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; } } @@ -2857,7 +3120,7 @@ PP(pp_int) } } } - RETURN; + return NORMAL; } PP(pp_abs) @@ -2885,7 +3148,7 @@ PP(pp_abs) } else { /* 2s complement assumption. Also, not really needed as IV_MIN and -IV_MIN should both be %100...00 and NV-able */ - SETu(IV_MIN); + SETu((UV)IV_MIN); } } } @@ -2897,7 +3160,7 @@ PP(pp_abs) SETn(value); } } - RETURN; + return NORMAL; } @@ -2911,7 +3174,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)) { @@ -2940,12 +3203,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. */ @@ -3102,7 +3365,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 */ @@ -3118,7 +3380,6 @@ PP(pp_substr) ? (STRLEN)(UV)len_iv : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv); - SPAGAIN; PUSHs(ret); /* avoid SvSETMAGIC here */ RETURN; } @@ -3188,7 +3449,6 @@ PP(pp_substr) SvREFCNT_dec(repl_sv_copy); } } - SPAGAIN; if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) SP++; else if (rvalue) { @@ -3197,7 +3457,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"); @@ -3265,7 +3525,7 @@ PP(pp_index) little_utf8 = DO_UTF8(little); if (big_utf8 ^ little_utf8) { /* One needs to be upgraded. */ - if (little_utf8 && !IN_ENCODING) { + if (little_utf8) { /* Well, maybe instead we might be able to downgrade the small string? */ char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen, @@ -3284,22 +3544,11 @@ PP(pp_index) sv_usepvn(temp, pv, llen); little_p = SvPVX(little); } else { - temp = little_utf8 - ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen); + temp = newSVpvn(little_p, llen); - if (IN_ENCODING) { - sv_recode_to_utf8(temp, _get_encoding()); - } else { - sv_utf8_upgrade(temp); - } - if (little_utf8) { - big = temp; - big_utf8 = TRUE; - big_p = SvPV_const(big, biglen); - } else { - little = temp; - little_p = SvPV_const(little, llen); - } + sv_utf8_upgrade(temp); + little = temp; + little_p = SvPV_const(little, llen); } } if (SvGAMAGIC(big)) { @@ -3317,7 +3566,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, @@ -3369,22 +3618,15 @@ PP(pp_ord) { dSP; dTARGET; - SV *argsv = POPs; + SV *argsv = TOPs; STRLEN len; const U8 *s = (U8*)SvPV_const(argsv, len); - if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) { - SV * const tmpsv = sv_2mortal(newSVsv(argsv)); - s = (U8*)sv_recode_to_utf8(tmpsv, _get_encoding()); - len = UTF8SKIP(s); /* Should be well-formed; so this is its length */ - 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) @@ -3392,7 +3634,7 @@ PP(pp_chr) dSP; dTARGET; char *tmps; UV value; - SV *top = POPs; + SV *top = TOPs; SvGETMAGIC(top); if (UNLIKELY(SvAMAGIC(top))) @@ -3404,7 +3646,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(); @@ -3423,14 +3666,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); @@ -3440,24 +3683,8 @@ PP(pp_chr) *tmps = '\0'; (void)SvPOK_only(TARG); - if (IN_ENCODING && !IN_BYTES) { - sv_recode_to_utf8(TARG, _get_encoding()); - tmps = SvPVX(TARG); - if (SvCUR(TARG) == 0 - || ! is_utf8_string((U8*)tmps, SvCUR(TARG)) - || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG))) - { - SvGROW(TARG, 2); - tmps = SvPVX(TARG); - SvCUR_set(TARG, 1); - *tmps++ = (char)value; - *tmps = '\0'; - SvUTF8_off(TARG); - } - } - - XPUSHTARG; - RETURN; + SETTARG; + return NORMAL; } PP(pp_crypt) @@ -3545,10 +3772,7 @@ PP(pp_ucfirst) /* 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 = !SvREADONLY(source) - && ( SvPADTMP(source) - || ( SvTEMP(source) && !SvSMAGICAL(source) - && SvREFCNT(source) == 1)); + inplace = !SvREADONLY(source) && SvPADTMP(source); /* 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, @@ -3591,23 +3815,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 */ @@ -3766,7 +3994,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 @@ -3784,9 +4012,7 @@ PP(pp_uc) SvGETMAGIC(source); - if ((SvPADTMP(source) - || - (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1)) + if ( SvPADTMP(source) && !SvREADONLY(source) && SvPOK(source) && !DO_UTF8(source) && ( @@ -3883,8 +4109,7 @@ PP(pp_uc) * allocate without allocating too much. Such is life. * See corresponding comment in lc code for another option * */ - SvGROW(dest, min); - d = (U8*)SvPVX(dest) + o; + d = o + (U8*) SvGROW(dest, min); } Copy(tmpbuf, d, ulen, U8); d += ulen; @@ -3912,6 +4137,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); } @@ -3938,18 +4164,21 @@ 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 * ASCII. If not enough room, grow the string */ if (SvLEN(dest) < ++min) { const UV o = d - (U8*)SvPVX_const(dest); - SvGROW(dest, min); - d = (U8*)SvPVX(dest) + o; + d = o + (U8*) SvGROW(dest, min); } *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 @@ -4023,7 +4252,7 @@ PP(pp_uc) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } PP(pp_lc) @@ -4038,10 +4267,7 @@ PP(pp_lc) SvGETMAGIC(source); - if ( ( SvPADTMP(source) - || ( SvTEMP(source) && !SvSMAGICAL(source) - && SvREFCNT(source) == 1 ) - ) + if ( SvPADTMP(source) && !SvREADONLY(source) && SvPOK(source) && !DO_UTF8(source)) { @@ -4097,8 +4323,7 @@ PP(pp_lc) * Another option would be to grow an extra byte or two more * each time we need to grow, which would cut down the million * to 500K, with little waste */ - SvGROW(dest, min); - d = (U8*)SvPVX(dest) + o; + d = o + (U8*) SvGROW(dest, min); } /* Copy the newly lowercased letter to the output buffer we're @@ -4119,6 +4344,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); } @@ -4149,7 +4375,7 @@ PP(pp_lc) if (dest != source && SvTAINTED(source)) SvTAINT(dest); SvSETMAGIC(dest); - RETURN; + return NORMAL; } PP(pp_quotemeta) @@ -4184,7 +4410,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; } @@ -4227,7 +4453,7 @@ PP(pp_quotemeta) else sv_setpvn(TARG, s, len); SETTARG; - RETURN; + return NORMAL; } PP(pp_fc) @@ -4242,8 +4468,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 ) @@ -4285,8 +4517,7 @@ PP(pp_fc) if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { const UV o = d - (U8*)SvPVX_const(dest); - SvGROW(dest, min); - d = (U8*)SvPVX(dest) + o; + d = o + (U8*) SvGROW(dest, min); } Copy(tmpbuf, d, ulen, U8); @@ -4301,6 +4532,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); } @@ -4364,8 +4596,7 @@ PP(pp_fc) * becomes "ss", which may require growing the SV. */ if (SvLEN(dest) < ++min) { const UV o = d - (U8*)SvPVX_const(dest); - SvGROW(dest, min); - d = (U8*)SvPVX(dest) + o; + d = o + (U8*) SvGROW(dest, min); } *(d)++ = 's'; *d = 's'; @@ -4504,52 +4735,11 @@ 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; AV *array = MUTABLE_AV(POPs); - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; IV *iterp = Perl_av_iter_p(aTHX_ array); const IV current = (*iterp)++; @@ -4575,7 +4765,7 @@ PP(pp_akeys) { dSP; AV *array = MUTABLE_AV(POPs); - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; *Perl_av_iter_p(aTHX_ array) = 0; @@ -4584,12 +4774,23 @@ PP(pp_akeys) PUSHi(av_tindex(array) + 1); } else if (gimme == G_ARRAY) { + if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) + /* diag_listed_as: Can't modify %s in %s */ + Perl_croak(aTHX_ + "Can't modify keys on array in list assignment"); + } + { IV n = Perl_av_len(aTHX_ array); IV i; EXTEND(SP, n + 1); - if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) { + if ( PL_op->op_type == OP_AKEYS + || ( PL_op->op_type == OP_AVHVSWITCH + && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS )) + { for (i = 0; i <= n; i++) { mPUSHi(i); } @@ -4600,6 +4801,7 @@ PP(pp_akeys) PUSHs(elem ? *elem : &PL_sv_undef); } } + } } RETURN; } @@ -4611,23 +4813,17 @@ PP(pp_each) dSP; HV * hash = MUTABLE_HV(POPs); HE *entry; - const I32 gimme = GIMME_V; + const U8 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); } } @@ -4641,7 +4837,7 @@ STATIC OP * S_do_delete_local(pTHX) { dSP; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; const MAGIC *mg; HV *stash; const bool sliced = !!(PL_op->op_private & OPpSLICE); @@ -4751,7 +4947,7 @@ S_do_delete_local(pTHX) PP(pp_delete) { dSP; - I32 gimme; + U8 gimme; I32 discard; if (PL_op->op_private & OPpLVAL_INTRO) @@ -4916,7 +5112,8 @@ PP(pp_kvhslice) 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"); + Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment", + GIMME_V == G_ARRAY ? "list" : "scalar"); lval = flags; } } @@ -4984,15 +5181,20 @@ PP(pp_lslice) SV **lelem; if (GIMME_V != G_ARRAY) { - I32 ix = SvIV(*lastlelem); - if (ix < 0) - ix += max; - if (ix < 0 || ix >= max) - *firstlelem = &PL_sv_undef; - else - *firstlelem = firstrelem[ix]; - SP = firstlelem; - RETURN; + if (lastlelem < firstlelem) { + *firstlelem = &PL_sv_undef; + } + else { + I32 ix = SvIV(*lastlelem); + if (ix < 0) + ix += max; + if (ix < 0 || ix >= max) + *firstlelem = &PL_sv_undef; + else + *firstlelem = firstrelem[ix]; + } + SP = firstlelem; + RETURN; } if (max == 0) { @@ -5046,7 +5248,7 @@ PP(pp_anonhash) MARK++; SvGETMAGIC(*MARK); val = newSV(0); - sv_setsv(val, *MARK); + sv_setsv_nomg(val, *MARK); } else { @@ -5060,41 +5262,11 @@ PP(pp_anonhash) RETURN; } -static AV * -S_deref_plain_array(pTHX_ AV *ary) -{ - if (SvTYPE(ary) == SVt_PVAV) return ary; - SvGETMAGIC((SV *)ary); - if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV) - Perl_die(aTHX_ "Not an ARRAY reference"); - else if (SvOBJECT(SvRV(ary))) - Perl_die(aTHX_ "Not an unblessed ARRAY reference"); - return (AV *)SvRV(ary); -} - -#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) -# define DEREF_PLAIN_ARRAY(ary) \ - ({ \ - AV *aRrRay = ary; \ - SvTYPE(aRrRay) == SVt_PVAV \ - ? aRrRay \ - : S_deref_plain_array(aTHX_ aRrRay); \ - }) -#else -# define DEREF_PLAIN_ARRAY(ary) \ - ( \ - PL_Sv = (SV *)(ary), \ - SvTYPE(PL_Sv) == SVt_PVAV \ - ? (AV *)PL_Sv \ - : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \ - ) -#endif - PP(pp_splice) { dSP; dMARK; dORIGMARK; int num_args = (SP - MARK); - AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); + AV *ary = MUTABLE_AV(*++MARK); SV **src; SV **dst; SSize_t i; @@ -5191,6 +5363,8 @@ PP(pp_splice) for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) SvREFCNT_dec(*dst++); /* free them now */ } + if (!*MARK) + *MARK = &PL_sv_undef; } AvFILLp(ary) += diff; @@ -5287,6 +5461,8 @@ PP(pp_splice) while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } + if (!*MARK) + *MARK = &PL_sv_undef; } else *MARK = &PL_sv_undef; @@ -5303,7 +5479,7 @@ PP(pp_splice) PP(pp_push) { dSP; dMARK; dORIGMARK; dTARGET; - AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); + AV * const ary = MUTABLE_AV(*++MARK); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { @@ -5313,9 +5489,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 +5508,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) { @@ -5343,7 +5522,7 @@ PP(pp_shift) { dSP; AV * const av = PL_op->op_flags & OPf_SPECIAL - ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs)); + ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs); SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); EXTEND(SP, 1); assert (sv); @@ -5356,7 +5535,7 @@ PP(pp_shift) PP(pp_unshift) { dSP; dMARK; dORIGMARK; dTARGET; - AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); + AV *ary = MUTABLE_AV(*++MARK); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { @@ -5366,15 +5545,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) { @@ -5471,7 +5658,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,10 +5722,10 @@ 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; + const U8 gimme = GIMME_V; bool gimme_scalar; const I32 oldsave = PL_savestack_ix; U32 make_mortal = SVs_TEMP; @@ -5560,15 +5747,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 +5896,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) { @@ -5974,7 +6166,7 @@ PP(pp_lock) } -/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops +/* used for: pp_padany(), pp_custom(); plus any system ops * that aren't implemented on a particular platform */ PP(unimplemented_op) @@ -5995,6 +6187,18 @@ PP(unimplemented_op) DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type); } +static void +S_maybe_unwind_defav(pTHX) +{ + if (CX_CUR()->cx_type & CXp_HASARGS) { + PERL_CONTEXT *cx = CX_CUR(); + + assert(CxHASARGS(cx)); + cx_popsub_args(cx); + cx->cx_type &= ~CXp_HASARGS; + } +} + /* For sorting out arguments passed to a &CORE:: subroutine */ PP(pp_coreargs) { @@ -6033,7 +6237,7 @@ PP(pp_coreargs) to return. nextstate usually does this on sub entry, but we need to run the next op with the caller's hints, so we cannot have a nextstate. */ - SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; + SP = PL_stack_base + CX_CUR()->blk_oldsp; if(!maxargs) RETURN; @@ -6055,10 +6259,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; @@ -6068,13 +6269,39 @@ PP(pp_coreargs) svp++; } RETURN; + case OA_AVREF: + if (!numargs) { + GV *gv; + if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL))) + gv = PL_argvgv; + else { + S_maybe_unwind_defav(aTHX); + gv = PL_defgv; + } + PUSHs((SV *)GvAVn(gv)); + break; + } + if (!svp || !*svp || !SvROK(*svp) + || SvTYPE(SvRV(*svp)) != SVt_PVAV) + DIE(aTHX_ + /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ + "Type of arg %d to &CORE::%s must be array reference", + whicharg, PL_op_desc[opnum] + ); + PUSHs(SvRV(*svp)); + break; case OA_HVREF: if (!svp || !*svp || !SvROK(*svp) - || SvTYPE(SvRV(*svp)) != SVt_PVHV) + || ( SvTYPE(SvRV(*svp)) != SVt_PVHV + && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN + || SvTYPE(SvRV(*svp)) != SVt_PVAV ))) DIE(aTHX_ /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ - "Type of arg %d to &CORE::%s must be hash reference", - whicharg, OP_DESC(PL_op->op_next) + "Type of arg %d to &CORE::%s must be hash%s reference", + whicharg, PL_op_desc[opnum], + opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN + ? "" + : " or array" ); PUSHs(SvRV(*svp)); break; @@ -6119,14 +6346,10 @@ PP(pp_coreargs) : "reference to one of [$@%*]" ); PUSHs(SvRV(*svp)); - if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv - && cxstack[cxstack_ix].cx_type & CXp_HASARGS) { + if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) { /* Undo @_ localisation, so that sub exit does not undo part of our undeffing. */ - PERL_CONTEXT *cx = &cxstack[cxstack_ix]; - POP_SAVEARRAY(); - cx->cx_type &= ~ CXp_HASARGS; - assert(!AvREAL(cx->blk_sub.argarray)); + S_maybe_unwind_defav(aTHX); } } break; @@ -6139,6 +6362,15 @@ PP(pp_coreargs) RETURN; } +PP(pp_avhvswitch) +{ + dVAR; dSP; + return PL_ppaddr[ + (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH) + + (PL_op->op_private & 3) + ](aTHX); +} + PP(pp_runcv) { dSP; @@ -6251,6 +6483,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 +6491,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 +6520,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 +6596,237 @@ PP(pp_lvavref) } } -/* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: +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; +} + + +/* process one subroutine argument - typically when the sub has a signature: + * introduce PL_curpad[op_targ] and assign to it the value + * for $: (OPf_STACKED ? *sp : $_[N]) + * for @/%: @_[N..$#_] + * + * It's equivalent to + * my $foo = $_[N]; + * or + * my $foo = (value-on-stack) + * or + * my @foo = @_[N..$#_] + * etc + */ + +PP(pp_argelem) +{ + dTARG; + SV *val; + SV ** padentry; + OP *o = PL_op; + AV *defav = GvAV(PL_defgv); /* @_ */ + IV ix = PTR2IV(cUNOP_AUXo->op_aux); + IV argc; + + /* do 'my $var, @var or %var' action */ + padentry = &(PAD_SVl(o->op_targ)); + save_clearsv(padentry); + targ = *padentry; + + if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) { + if (o->op_flags & OPf_STACKED) { + dSP; + val = POPs; + PUTBACK; + } + else { + SV **svp; + /* should already have been checked */ + assert(ix >= 0); +#if IVSIZE > PTRSIZE + assert(ix <= SSize_t_MAX); +#endif + + svp = av_fetch(defav, ix, FALSE); + val = svp ? *svp : &PL_sv_undef; + } + + /* $var = $val */ + + /* cargo-culted from pp_sassign */ + assert(TAINTING_get || !TAINT_get); + if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) + TAINT_NOT; + + SvSetMagicSV(targ, val); + return o->op_next; + } + + /* must be AV or HV */ + + assert(!(o->op_flags & OPf_STACKED)); + argc = ((IV)AvFILL(defav) + 1) - ix; + + /* This is a copy of the relevant parts of pp_aassign(). + */ + if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) { + IV i; + + if (AvFILL((AV*)targ) > -1) { + /* target should usually be empty. If we get get + * here, someone's been doing some weird closure tricks. + * Make a copy of all args before clearing the array, + * to avoid the equivalent of @a = ($a[0]) prematurely freeing + * elements. See similar code in pp_aassign. + */ + for (i = 0; i < argc; i++) { + SV **svp = av_fetch(defav, ix + i, FALSE); + SV *newsv = newSV(0); + sv_setsv_flags(newsv, + svp ? *svp : &PL_sv_undef, + (SV_DO_COW_SVSETSV|SV_NOSTEAL)); + if (!av_store(defav, ix + i, newsv)) + SvREFCNT_dec_NN(newsv); + } + av_clear((AV*)targ); + } + + if (argc <= 0) + return o->op_next; + + av_extend((AV*)targ, argc); + + i = 0; + while (argc--) { + SV *tmpsv; + SV **svp = av_fetch(defav, ix + i, FALSE); + SV *val = svp ? *svp : &PL_sv_undef; + tmpsv = newSV(0); + sv_setsv(tmpsv, val); + av_store((AV*)targ, i++, tmpsv); + TAINT_NOT; + } + + } + else { + IV i; + + assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV); + + if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) { + /* see "target should usually be empty" comment above */ + for (i = 0; i < argc; i++) { + SV **svp = av_fetch(defav, ix + i, FALSE); + SV *newsv = newSV(0); + sv_setsv_flags(newsv, + svp ? *svp : &PL_sv_undef, + (SV_DO_COW_SVSETSV|SV_NOSTEAL)); + if (!av_store(defav, ix + i, newsv)) + SvREFCNT_dec_NN(newsv); + } + hv_clear((HV*)targ); + } + + if (argc <= 0) + return o->op_next; + assert(argc % 2 == 0); + + i = 0; + while (argc) { + SV *tmpsv; + SV **svp; + SV *key; + SV *val; + + svp = av_fetch(defav, ix + i++, FALSE); + key = svp ? *svp : &PL_sv_undef; + svp = av_fetch(defav, ix + i++, FALSE); + val = svp ? *svp : &PL_sv_undef; + + argc -= 2; + if (UNLIKELY(SvGMAGICAL(key))) + key = sv_mortalcopy(key); + tmpsv = newSV(0); + sv_setsv(tmpsv, val); + hv_store_ent((HV*)targ, key, tmpsv, 0); + TAINT_NOT; + } + } + + return o->op_next; +} + +/* Handle a default value for one subroutine argument (typically as part + * of a subroutine signature). + * It's equivalent to + * @_ > op_targ ? $_[op_targ] : result_of(op_other) * + * Intended to be used where op_next is an OP_ARGELEM + * + * We abuse the op_targ field slightly: it's an index into @_ rather than + * into PL_curpad. + */ + +PP(pp_argdefelem) +{ + OP * const o = PL_op; + AV *defav = GvAV(PL_defgv); /* @_ */ + IV ix = (IV)o->op_targ; + + assert(ix >= 0); +#if IVSIZE > PTRSIZE + assert(ix <= SSize_t_MAX); +#endif + + if (AvFILL(defav) >= ix) { + dSP; + SV **svp = av_fetch(defav, ix, FALSE); + SV *val = svp ? *svp : &PL_sv_undef; + XPUSHs(val); + RETURN; + } + return cLOGOPo->op_other; +} + + + +/* Check a a subs arguments - i.e. that it has the correct number of args + * (and anything else we might think of in future). Typically used with + * signatured subs. + */ + +PP(pp_argcheck) +{ + OP * const o = PL_op; + UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; + IV params = aux[0].iv; + IV opt_params = aux[1].iv; + char slurpy = (char)(aux[2].iv); + AV *defav = GvAV(PL_defgv); /* @_ */ + IV argc; + bool too_few; + + assert(!SvMAGICAL(defav)); + argc = (AvFILLp(defav) + 1); + too_few = (argc < (params - opt_params)); + + if (UNLIKELY(too_few || (!slurpy && argc > params))) + /* diag_listed_as: Too few arguments for subroutine */ + /* diag_listed_as: Too many arguments for subroutine */ + Perl_croak_caller("Too %s arguments for subroutine", + too_few ? "few" : "many"); + + if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2)) + Perl_croak_caller("Odd name/value argument for subroutine"); + + + return NORMAL; +} + +/* * ex: set ts=8 sts=4 sw=4 et: */