X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f2bd3a8b9855e84ab43505429524667042927760..06c6da524f9e0eae167367edc8fe0150d69893fa:/pp.c diff --git a/pp.c b/pp.c index e05b6d9..997b5ba 100644 --- a/pp.c +++ b/pp.c @@ -71,11 +71,14 @@ PP(pp_padav) if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; - } else if (LVRET) { + } else if (PL_op->op_private & OPpMAYBE_LVSUB) { + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { if (GIMME == G_SCALAR) Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); PUSHs(TARG); RETURN; + } } gimme = GIMME_V; if (gimme == G_ARRAY) { @@ -114,10 +117,13 @@ PP(pp_padhv) SAVECLEARSV(PAD_SVl(PL_op->op_targ)); if (PL_op->op_flags & OPf_REF) RETURN; - else if (LVRET) { + else if (PL_op->op_private & OPpMAYBE_LVSUB) { + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { if (GIMME == G_SCALAR) Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); RETURN; + } } gimme = GIMME_V; if (gimme == G_ARRAY) { @@ -712,15 +718,18 @@ PP(pp_study) RETPUSHYES; } s = (unsigned char*)(SvPV(sv, len)); - pos = len; - if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) { + if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) { /* No point in studying a zero length string, and not safe to study anything that doesn't appear to be a simple scalar (and hence might change between now and when the regexp engine runs without our set magic ever running) such as a reference to an object with overloaded - stringification. */ + stringification. Also refuse to study an FBM scalar, as this gives + more flexibility in SV flag usage. No real-world code would ever + end up studying an FBM scalar, so this isn't a real pessimisation. + */ RETPUSHNO; } + pos = len; if (PL_lastscream) { SvSCREAM_off(PL_lastscream); @@ -728,10 +737,6 @@ PP(pp_study) } PL_lastscream = SvREFCNT_inc_simple(sv); - s = (unsigned char*)(SvPV(sv, len)); - pos = len; - if (pos <= 0) - RETPUSHNO; if (pos > PL_maxscream) { if (PL_maxscream < 0) { PL_maxscream = pos + 80; @@ -2054,16 +2059,6 @@ PP(pp_lt) } } #endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); - RETURN; - } -#endif { #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) dPOPTOPnnrl_nomg; @@ -2138,16 +2133,6 @@ PP(pp_gt) } } #endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s))); - RETURN; - } -#endif { #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) dPOPTOPnnrl_nomg; @@ -2222,16 +2207,6 @@ PP(pp_le) } } #endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); - RETURN; - } -#endif { #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) dPOPTOPnnrl_nomg; @@ -2306,16 +2281,6 @@ PP(pp_ge) } } #endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s))); - RETURN; - } -#endif { #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) dPOPTOPnnrl_nomg; @@ -2334,13 +2299,6 @@ PP(pp_ne) { dVAR; dSP; tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric); -#ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s))); - RETURN; - } -#endif #ifdef PERL_PRESERVE_IVUV SvIV_please_nomg(TOPs); if (SvIOK(TOPs)) { @@ -2411,14 +2369,6 @@ PP(pp_ncmp) { dVAR; dSP; dTARGET; tryAMAGICbin_MG(ncmp_amg, AMGf_numeric); -#ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - const UV right = PTR2UV(SvRV(POPs)); - const UV left = PTR2UV(SvRV(TOPs)); - SETi((left > right) - (left < right)); - RETURN; - } -#endif #ifdef PERL_PRESERVE_IVUV /* Fortunately it seems NaN isn't IOK */ SvIV_please_nomg(TOPs); @@ -2489,7 +2439,7 @@ PP(pp_ncmp) dPOPTOPnnrl_nomg; I32 value; -#ifdef Perl_isnan +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) if (Perl_isnan(left) || Perl_isnan(right)) { SETs(&PL_sv_undef); RETURN; @@ -3016,7 +2966,7 @@ PP(pp_i_ge) dVAR; dSP; tryAMAGICbin_MG(ge_amg, AMGf_set); { - dPOPTOPiirl_halfmg; + dPOPTOPiirl_nomg; SETs(boolSV(left >= right)); RETURN; } @@ -3027,7 +2977,7 @@ PP(pp_i_eq) dVAR; dSP; tryAMAGICbin_MG(eq_amg, AMGf_set); { - dPOPTOPiirl_halfmg; + dPOPTOPiirl_nomg; SETs(boolSV(left == right)); RETURN; } @@ -3038,7 +2988,7 @@ PP(pp_i_ne) dVAR; dSP; tryAMAGICbin_MG(ne_amg, AMGf_set); { - dPOPTOPiirl_halfmg; + dPOPTOPiirl_nomg; SETs(boolSV(left != right)); RETURN; } @@ -3049,7 +2999,7 @@ PP(pp_i_ncmp) dVAR; dSP; dTARGET; tryAMAGICbin_MG(ncmp_amg, 0); { - dPOPTOPiirl_halfmg; + dPOPTOPiirl_nomg; I32 value; if (left > right) @@ -3082,7 +3032,7 @@ PP(pp_atan2) dVAR; dSP; dTARGET; tryAMAGICbin_MG(atan2_amg, 0); { - dPOPTOPnnrl_halfmg; + dPOPTOPnnrl_nomg; SETn(Perl_atan2(left, right)); RETURN; } @@ -4836,54 +4786,26 @@ PP(pp_rkeys) dSP; dPOPss; - if (!SvOK(sv)) - RETURN; - - if (SvROK(sv)) { - SvGETMAGIC(sv); - if (SvAMAGIC(sv)) { - /* N.B.: AMG macros return sv if no overloading is found */ - SV *maybe_hv = AMG_CALLunary(sv, to_hv_amg); - SV *maybe_av = AMG_CALLunary(sv, to_av_amg); - if ( maybe_hv != sv && maybe_av != sv ) { - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", - Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}", - PL_op_desc[PL_op->op_type] - ) - ); - sv = maybe_hv; - } - else if ( maybe_av != sv ) { - if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) { - /* @{} overload, but underlying reftype is HV */ - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", - Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}", - PL_op_desc[PL_op->op_type] - ) - ); - } - sv = maybe_av; - } - else if ( maybe_hv != sv ) { - if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) { - /* %{} overload, but underlying reftype is AV */ - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", - Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}", - PL_op_desc[PL_op->op_type] - ) - ); - } - sv = maybe_hv; - } - } - sv = SvRV(sv); - } - - if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) { - DIE(aTHX_ "Type of argument to %s must be hashref or arrayref", + 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) { @@ -5424,10 +5346,41 @@ 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) { dVAR; dSP; dMARK; dORIGMARK; - register AV *ary = MUTABLE_AV(*++MARK); + int num_args = (SP - MARK); + register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); register SV **src; register SV **dst; register I32 i; @@ -5470,7 +5423,8 @@ PP(pp_splice) length = AvMAX(ary) + 1; } if (offset > AvFILLp(ary) + 1) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); + if (num_args > 2) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); offset = AvFILLp(ary) + 1; } after = AvFILLp(ary) + 1 - (offset + length); @@ -5630,7 +5584,7 @@ PP(pp_splice) PP(pp_push) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; - register AV * const ary = MUTABLE_AV(*++MARK); + register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { @@ -5667,7 +5621,7 @@ PP(pp_shift) dVAR; dSP; AV * const av = PL_op->op_flags & OPf_SPECIAL - ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs); + ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs)); SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av); EXTEND(SP, 1); assert (sv); @@ -5680,7 +5634,7 @@ PP(pp_shift) PP(pp_unshift) { dVAR; dSP; dMARK; dORIGMARK; dTARGET; - register AV *ary = MUTABLE_AV(*++MARK); + register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); if (mg) { @@ -6143,7 +6097,7 @@ PP(pp_split) I32 rex_return; PUTBACK; rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 , - sv, NULL, 0); + sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0); SPAGAIN; if (rex_return == 0) break; @@ -6337,7 +6291,7 @@ PP(pp_boolkeys) } } - XPUSHs(boolSV(HvKEYS(hv) != 0)); + XPUSHs(boolSV(HvUSEDKEYS(hv) != 0)); RETURN; }