X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0824d66743a706cd268ace8fc9df03d7374c6886..46787c0e32a676e3fcb60d752d4858316dc1ef77:/pp.c diff --git a/pp.c b/pp.c index 937fdfd..9e762d5 100644 --- a/pp.c +++ b/pp.c @@ -139,10 +139,11 @@ PP(pp_rv2gv) { dVAR; dSP; dTOPss; - SvGETMAGIC(sv); + if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv); if (SvROK(sv)) { wasref: - tryAMAGICunDEREF(to_gv); + sv = amagic_deref_call(sv, to_gv_amg); + SPAGAIN; sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVIO) { @@ -162,7 +163,7 @@ PP(pp_rv2gv) * NI-S 1999/05/07 */ if (SvREADONLY(sv)) - Perl_croak(aTHX_ "%s", PL_no_modify); + Perl_croak_no_modify(aTHX); if (PL_op->op_private & OPpDEREF) { GV *gv; if (cUNOP->op_targ) { @@ -213,11 +214,19 @@ PP(pp_rv2gv) } sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV)); } + /* FAKE globs in the symbol table cause weird bugs (#77810) */ + if (sv) SvFAKE_off(sv); } } if (PL_op->op_private & OPpLVAL_INTRO) save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); - SETs(sv); + if (sv && SvFAKE(sv)) { + SV *newsv = sv_newmortal(); + sv_setsv_flags(newsv, sv, 0); + SvFAKE_off(newsv); + SETs(newsv); + } + else SETs(sv); RETURN; } @@ -275,7 +284,8 @@ PP(pp_rv2sv) if (!(PL_op->op_private & OPpDEREFed)) SvGETMAGIC(sv); if (SvROK(sv)) { - tryAMAGICunDEREF(to_sv); + sv = amagic_deref_call(sv, to_sv_amg); + SPAGAIN; sv = SvRV(sv); switch (SvTYPE(sv)) { @@ -336,26 +346,21 @@ PP(pp_av2arylen) PP(pp_pos) { - dVAR; dSP; dTARGET; dPOPss; + dVAR; dSP; dPOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { - if (SvTYPE(TARG) < SVt_PVLV) { - sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0); - } - - LvTYPE(TARG) = '.'; - if (LvTARG(TARG) != sv) { - SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc_simple(sv); - } - PUSHs(TARG); /* no SvSETMAGIC */ + 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; } else { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global); if (mg && mg->mg_len >= 0) { + dTARGET; I32 i = mg->mg_len; if (DO_UTF8(sv)) sv_pos_b2u(sv, &i); @@ -426,7 +431,27 @@ PP(pp_prototype) goto set; } if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) { - ret = newSVpvs_flags("\\[@%]", SVs_TEMP); + ret = newSVpvs_flags("+", SVs_TEMP); + goto set; + } + if (code == -KEY_push || code == -KEY_unshift) { + ret = newSVpvs_flags("+@", SVs_TEMP); + goto set; + } + if (code == -KEY_pop || code == -KEY_shift) { + ret = newSVpvs_flags(";+", SVs_TEMP); + goto set; + } + if (code == -KEY_splice) { + ret = newSVpvs_flags("+;$$@", SVs_TEMP); + goto set; + } + if (code == -KEY_tied || code == -KEY_untie) { + ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP); + goto set; + } + if (code == -KEY_tie) { + ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP); goto set; } if (code == -KEY_readpipe) { @@ -752,7 +777,12 @@ PP(pp_trans) EXTEND(SP,1); } TARG = sv_newmortal(); - PUSHi(do_trans(sv)); + if(PL_op->op_type == OP_TRANSR) { + SV * const newsv = newSVsv(sv); + do_trans(newsv); + mPUSHs(newsv); + } + else PUSHi(do_trans(sv)); RETURN; } @@ -830,7 +860,7 @@ PP(pp_undef) /* let user-undef'd sub keep its identity */ GV* const gv = CvGV((const CV *)sv); cv_undef(MUTABLE_CV(sv)); - CvGV((const CV *)sv) = gv; + CvGV_set(MUTABLE_CV(sv), gv); } break; case SVt_PVGV: @@ -842,13 +872,16 @@ PP(pp_undef) GP *gp; HV *stash; - /* undef *Foo:: */ - if((stash = GvHV((const GV *)sv)) && HvNAME_get(stash)) - mro_isa_changed_in(stash); /* undef *Pkg::meth_name ... */ - else if(GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv)) - && HvNAME_get(stash)) - mro_method_changed_in(stash); + bool method_changed + = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv)) + && HvENAME_get(stash); + /* undef *Foo:: */ + if((stash = GvHV((const GV *)sv))) { + if(HvENAME_get(stash)) + SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash)); + else stash = NULL; + } gp_free(MUTABLE_GV(sv)); Newxz(gp, 1, GP); @@ -857,6 +890,20 @@ PP(pp_undef) GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = MUTABLE_GV(sv); GvMULTI_on(sv); + + if(stash) + mro_package_moved(NULL, stash, (const GV *)sv, NULL, 0); + stash = NULL; + /* undef *Foo::ISA */ + if( strEQ(GvNAME((const GV *)sv), "ISA") + && (stash = GvSTASH((const GV *)sv)) + && (method_changed || HvENAME(stash)) ) + mro_isa_changed_in(stash); + else if(method_changed) + mro_method_changed_in( + GvSTASH((const GV *)sv) + ); + break; } /* FALL THROUGH */ @@ -877,7 +924,7 @@ PP(pp_predec) { dVAR; dSP; if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) - DIE(aTHX_ "%s", PL_no_modify); + Perl_croak_no_modify(aTHX); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { @@ -894,7 +941,9 @@ PP(pp_postinc) { dVAR; dSP; dTARGET; if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) - DIE(aTHX_ "%s", PL_no_modify); + Perl_croak_no_modify(aTHX); + if (SvROK(TOPs)) + TARG = sv_newmortal(); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) @@ -916,7 +965,9 @@ PP(pp_postdec) { dVAR; dSP; dTARGET; if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) - DIE(aTHX_ "%s", PL_no_modify); + Perl_croak_no_modify(aTHX); + if (SvROK(TOPs)) + TARG = sv_newmortal(); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) @@ -2329,8 +2380,8 @@ PP(pp_sle) { dPOPTOPssrl; const int cmp = (IN_LOCALE_RUNTIME - ? sv_cmp_locale(left, right) - : sv_cmp(left, right)); + ? sv_cmp_locale_flags(left, right, 0) + : sv_cmp_flags(left, right, 0)); SETs(boolSV(cmp * multiplier < rhs)); RETURN; } @@ -2342,7 +2393,7 @@ PP(pp_seq) tryAMAGICbin_MG(seq_amg, AMGf_set); { dPOPTOPssrl; - SETs(boolSV(sv_eq(left, right))); + SETs(boolSV(sv_eq_flags(left, right, 0))); RETURN; } } @@ -2353,7 +2404,7 @@ PP(pp_sne) tryAMAGICbin_MG(sne_amg, AMGf_set); { dPOPTOPssrl; - SETs(boolSV(!sv_eq(left, right))); + SETs(boolSV(!sv_eq_flags(left, right, 0))); RETURN; } } @@ -2365,8 +2416,8 @@ PP(pp_scmp) { dPOPTOPssrl; const int cmp = (IN_LOCALE_RUNTIME - ? sv_cmp_locale(left, right) - : sv_cmp(left, right)); + ? sv_cmp_locale_flags(left, right, 0) + : sv_cmp_flags(left, right, 0)); SETi( cmp ); RETURN; } @@ -2379,6 +2430,8 @@ PP(pp_bit_and) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { + const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); + const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); if (PL_op->op_private & HINT_INTEGER) { const IV i = SvIV_nomg(left) & SvIV_nomg(right); SETi(i); @@ -2387,6 +2440,8 @@ PP(pp_bit_and) const UV u = SvUV_nomg(left) & SvUV_nomg(right); SETu(u); } + if (left_ro_nonnum) SvNIOK_off(left); + if (right_ro_nonnum) SvNIOK_off(right); } else { do_vop(PL_op->op_type, TARG, left, right); @@ -2405,6 +2460,8 @@ PP(pp_bit_or) { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { + const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left); + const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right); if (PL_op->op_private & HINT_INTEGER) { const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0); const IV r = SvIV_nomg(right); @@ -2417,6 +2474,8 @@ PP(pp_bit_or) const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r); SETu(result); } + if (left_ro_nonnum) SvNIOK_off(left); + if (right_ro_nonnum) SvNIOK_off(right); } else { do_vop(op_type, TARG, left, right); @@ -2433,6 +2492,11 @@ PP(pp_negate) { SV * const sv = TOPs; const int flags = SvFLAGS(sv); + + if( !SvNIOK( sv ) && looks_like_number( sv ) ){ + SvIV_please( sv ); + } + if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { /* It's publicly an integer, or privately an integer-not-float */ oops_its_an_int: @@ -2500,7 +2564,7 @@ PP(pp_not) { dVAR; dSP; tryAMAGICun_MG(not_amg, AMGf_set); - *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); + *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp)); return NORMAL; } @@ -2942,12 +3006,19 @@ PP(pp_rand) PP(pp_srand) { - dVAR; dSP; + dVAR; dSP; dTARGET; const UV anum = (MAXARG < 1) ? seed() : POPu; (void)seedDrand01((Rand_seed_t)anum); PL_srand_called = TRUE; - EXTEND(SP, 1); - RETPUSHYES; + if (anum) + XPUSHu(anum); + else { + /* Historically srand always returned true. We can avoid breaking + that like this: */ + sv_setpvs(TARG, "0 but true"); + XPUSHTARG; + } + RETURN; } PP(pp_int) @@ -3059,11 +3130,11 @@ PP(pp_oct) tmps++, len--; if (*tmps == '0') tmps++, len--; - if (*tmps == 'x') { + if (*tmps == 'x' || *tmps == 'X') { hex: result_uv = grok_hex (tmps, &len, &flags, &result_nv); } - else if (*tmps == 'b') + else if (*tmps == 'b' || *tmps == 'B') result_uv = grok_bin (tmps, &len, &flags, &result_nv); else result_uv = grok_oct (tmps, &len, &flags, &result_nv); @@ -3095,8 +3166,10 @@ PP(pp_length) = sv_2pv_flags(sv, &len, SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC); - if (!p) - SETs(&PL_sv_undef); + if (!p) { + sv_setsv(TARG, &PL_sv_undef); + SETTARG; + } else if (DO_UTF8(sv)) { SETi(utf8_length((U8*)p, (U8*)p + len)); } @@ -3109,7 +3182,8 @@ PP(pp_length) else SETi(sv_len(sv)); } else { - SETs(&PL_sv_undef); + sv_setsv_nomg(TARG, &PL_sv_undef); + SETTARG; } RETURN; } @@ -3138,8 +3212,6 @@ PP(pp_substr) bool repl_need_utf8_upgrade = FALSE; bool repl_is_utf8 = FALSE; - SvTAINTED_off(TARG); /* decontaminate */ - SvUTF8_off(TARG); /* decontaminate */ if (num_args > 2) { if (num_args > 3) { repl_sv = POPs; @@ -3247,26 +3319,46 @@ PP(pp_substr) STRLEN byte_pos = utf8_curlen ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos; - tmps += byte_pos; - /* we either return a PV or an LV. If the TARG hasn't been used - * before, or is of that type, reuse it; otherwise use a mortal - * instead. Note that LVs can have an extended lifetime, so also - * dont reuse if refcount > 1 (bug #20933) */ - if (SvTYPE(TARG) > SVt_NULL) { - if ( (SvTYPE(TARG) == SVt_PVLV) - ? (!lvalue || SvREFCNT(TARG) > 1) - : lvalue) - { - TARG = sv_newmortal(); + if (lvalue && !repl) { + SV * ret; + + if (!SvGMAGICAL(sv)) { + if (SvROK(sv)) { + SvPV_force_nolen(sv); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), + "Attempt to use reference as lvalue in substr"); + } + if (isGV_with_GP(sv)) + SvPV_force_nolen(sv); + else if (SvOK(sv)) /* is it defined ? */ + (void)SvPOK_only_UTF8(sv); + else + sv_setpvs(sv, ""); /* avoid lexical reincarnation */ } + + ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ + sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0); + LvTYPE(ret) = 'x'; + LvTARG(ret) = SvREFCNT_inc_simple(sv); + LvTARGOFF(ret) = pos; + LvTARGLEN(ret) = len; + + SPAGAIN; + PUSHs(ret); /* avoid SvSETMAGIC here */ + RETURN; } + SvTAINTED_off(TARG); /* decontaminate */ + SvUTF8_off(TARG); /* decontaminate */ + + tmps += byte_pos; sv_setpvn(TARG, tmps, byte_len); #ifdef USE_LOCALE_COLLATE sv_unmagic(TARG, PERL_MAGIC_collxfrm); #endif if (utf8_curlen) SvUTF8_on(TARG); + if (repl) { SV* repl_sv_copy = NULL; @@ -3283,34 +3375,6 @@ PP(pp_substr) SvUTF8_on(sv); SvREFCNT_dec(repl_sv_copy); } - else if (lvalue) { /* it's an lvalue! */ - if (!SvGMAGICAL(sv)) { - if (SvROK(sv)) { - SvPV_force_nolen(sv); - Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), - "Attempt to use reference as lvalue in substr"); - } - if (isGV_with_GP(sv)) - SvPV_force_nolen(sv); - else if (SvOK(sv)) /* is it defined ? */ - (void)SvPOK_only_UTF8(sv); - else - sv_setpvs(sv, ""); /* avoid lexical reincarnation */ - } - - if (SvTYPE(TARG) < SVt_PVLV) { - sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0); - } - - LvTYPE(TARG) = 'x'; - if (LvTARG(TARG) != sv) { - SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc_simple(sv); - } - LvTARGOFF(TARG) = pos; - LvTARGLEN(TARG) = len; - } } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -3325,31 +3389,29 @@ bound_fail: PP(pp_vec) { - dVAR; dSP; dTARGET; + dVAR; dSP; register const IV size = POPi; register const IV offset = POPi; register SV * const src = POPs; const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; + SV * ret; - SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ - if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */ - TARG = sv_newmortal(); - if (SvTYPE(TARG) < SVt_PVLV) { - sv_upgrade(TARG, SVt_PVLV); - sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0); - } - LvTYPE(TARG) = 'v'; - if (LvTARG(TARG) != src) { - SvREFCNT_dec(LvTARG(TARG)); - LvTARG(TARG) = SvREFCNT_inc_simple(src); - } - LvTARGOFF(TARG) = offset; - LvTARGLEN(TARG) = size; + ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ + sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0); + LvTYPE(ret) = 'v'; + LvTARG(ret) = SvREFCNT_inc_simple(src); + LvTARGOFF(ret) = offset; + LvTARGLEN(ret) = size; + } + else { + dTARGET; + SvTAINTED_off(TARG); /* decontaminate */ + ret = TARG; } - sv_setuv(TARG, do_vecget(src, offset, size)); - PUSHs(TARG); + sv_setuv(ret, do_vecget(src, offset, size)); + PUSHs(ret); RETURN; } @@ -3610,7 +3672,6 @@ PP(pp_crypt) #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); - return NORMAL; #endif } @@ -4056,18 +4117,19 @@ PP(pp_uc) const U8 *const send = s + len; U8 tmpbuf[UTF8_MAXBYTES+1]; -/* This is ifdefd out because it needs more work and thought. It isn't clear - * that we should do it. These are hard-coded rules from the Unicode standard, - * and may change. 5.2 gives new guidance on the iota subscript, for example, - * which has not been checked against this; and secondly it may be that we are - * passed a subset of the context, via a \U...\E, for example, and its not - * clear what the best approach is to that */ -#ifdef CONTEXT_DEPENDENT_CASING + /* All occurrences of these are to be moved to follow any other marks. + * This is context-dependent. We may not be passed enough context to + * move the iota subscript beyond all of them, but we do the best we can + * with what we're given. The result is always better than if we + * hadn't done this. And, the problem would only arise if we are + * passed a character without all its combining marks, which would be + * the caller's mistake. The information this is based on comes from a + * comment in Unicode SpecialCasing.txt, (and the Standard's text + * itself) and so can't be checked properly to see if it ever gets + * revised. But the likelihood of it changing is remote */ bool in_iota_subscript = FALSE; -#endif while (s < send) { -#ifdef CONTEXT_DEPENDENT_CASING if (in_iota_subscript && ! is_utf8_mark(s)) { /* A non-mark. Time to output the iota subscript */ #define GREEK_CAPITAL_LETTER_IOTA 0x0399 @@ -4076,7 +4138,6 @@ PP(pp_uc) CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA); in_iota_subscript = FALSE; } -#endif /* See comments at the first instance in this file of this ifdef */ @@ -4108,15 +4169,13 @@ PP(pp_uc) const STRLEN u = UTF8SKIP(s); STRLEN ulen; -#ifndef CONTEXT_DEPENDENT_CASING - toUPPER_utf8(s, tmpbuf, &ulen); -#else const UV uv = toUPPER_utf8(s, tmpbuf, &ulen); - if (uv == GREEK_CAPITAL_LETTER_IOTA && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI) { + if (uv == GREEK_CAPITAL_LETTER_IOTA + && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI) + { in_iota_subscript = TRUE; } else { -#endif if (ulen > u && (SvLEN(dest) < (min += ulen - u))) { /* If the eventually required minimum size outgrows * the available space, we need to grow. */ @@ -4125,26 +4184,25 @@ PP(pp_uc) /* If someone uppercases one million U+03B0s we * SvGROW() one million times. Or we could try * guessing how much to allocate without allocating too - * much. Such is life. See corresponding comment in lc code - * for another option */ + * much. Such is life. See corresponding comment in + * lc code for another option */ SvGROW(dest, min); d = (U8*)SvPVX(dest) + o; } Copy(tmpbuf, d, ulen, U8); d += ulen; -#ifdef CONTEXT_DEPENDENT_CASING } -#endif s += u; } } -#ifdef CONTEXT_DEPENDENT_CASING - if (in_iota_subscript) CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA); -#endif + if (in_iota_subscript) { + CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA); + } SvUTF8_on(dest); *d = '\0'; SvCUR_set(dest, d - (U8*)SvPVX_const(dest)); - } else { /* Not UTF-8 */ + } + else { /* Not UTF-8 */ if (len) { const U8 *const send = s + len; @@ -4345,12 +4403,23 @@ PP(pp_lc) const STRLEN u = UTF8SKIP(s); STRLEN ulen; -/* See comments at the first instance in this file of this ifdef */ #ifndef CONTEXT_DEPENDENT_CASING toLOWER_utf8(s, tmpbuf, &ulen); #else - /* Here is context dependent casing, not compiled in currently; - * needs more thought and work */ +/* This is ifdefd out because it needs more work and thought. It isn't clear + * that we should do it. + * A minor objection is that this is based on a hard-coded rule from the + * Unicode standard, and may change, but this is not very likely at all. + * mktables should check and warn if it does. + * More importantly, if the sigma occurs at the end of the string, we don't + * have enough context to know whether it is part of a larger string or going + * to be or not. It may be that we are passed a subset of the context, via + * a \U...\E, for example, and we could conceivably know the larger context if + * code were changed to pass that in. But, if the string passed in is an + * intermediate result, and the user concatenates two strings together + * after we have made a final sigma, that would be wrong. If the final sigma + * occurs in the middle of the string we are working on, then we know that it + * should be a final sigma, but otherwise we can't be sure. */ const UV uv = toLOWER_utf8(s, tmpbuf, &ulen); @@ -4592,6 +4661,71 @@ PP(pp_aslice) RETURN; } +/* Smart dereferencing for keys, values and each */ +PP(pp_rkeys) +{ + dVAR; + 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_CALLun(sv,to_hv); + SV *maybe_av = AMG_CALLun(sv,to_av); + 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_ Perl_form(aTHX_ "Type of argument to %s must be hashref or arrayref", + PL_op_desc[PL_op->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) { dVAR; @@ -4637,7 +4771,7 @@ PP(pp_akeys) EXTEND(SP, n + 1); - if (PL_op->op_type == OP_AKEYS) { + if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) { n += i; for (; i <= n; i++) { mPUSHi(i); @@ -5322,6 +5456,10 @@ PP(pp_splice) *MARK = &PL_sv_undef; Safefree(tmparyval); } + + if (SvMAGICAL(ary)) + mg_set(MUTABLE_SV(ary)); + SP = MARK; RETURN; } @@ -5349,7 +5487,7 @@ PP(pp_push) sv_setsv(sv, *MARK); av_store(ary, AvFILLp(ary)+1, sv); } - if (PL_delaymagic & DM_ARRAY) + if (PL_delaymagic & DM_ARRAY_ISA) mg_set(MUTABLE_SV(ary)); PL_delaymagic = 0; @@ -5489,19 +5627,12 @@ PP(pp_reverse) register I32 tmp; dTARGET; STRLEN len; - PADOFFSET padoff_du; SvUTF8_off(TARG); /* decontaminate */ if (SP - MARK > 1) do_join(TARG, &PL_sv_no, MARK, SP); else { - sv_setsv(TARG, (SP > MARK) - ? *SP - : (padoff_du = find_rundefsvoffset(), - (padoff_du == NOT_IN_PAD - || PAD_COMPNAME_FLAGS_isOUR(padoff_du)) - ? DEFSV : PAD_SVl(padoff_du))); - + sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv()); if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED)) report_uninit(TARG); } @@ -6011,7 +6142,6 @@ PP(unimplemented_op) dVAR; DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op), PL_op->op_type); - return NORMAL; } PP(pp_boolkeys)