X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9e59c36b452568c56b99957f02b853c42e280f8a..60f638af330875e8b950f0d9f9f21a53e38c1d41:/pp.c diff --git a/pp.c b/pp.c index 7301d8b..1fba3d9 100644 --- a/pp.c +++ b/pp.c @@ -66,25 +66,28 @@ 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 */ @@ -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 @@ -805,17 +809,6 @@ 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) { if (s && len) { @@ -857,14 +850,6 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) } 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); @@ -1360,14 +1345,19 @@ PP(pp_multiply) NV nr = SvNVX(svr); NV result; - il = (IV)nl; - ir = (IV)nr; - if (nl == (NV)il && nr == (NV)ir) + 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_BIG_ENDIAN && NVSIZE == 16 +# 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); } @@ -1499,7 +1489,7 @@ PP(pp_multiply) NV result = left * right; (void)POPs; -#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16 +#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); } @@ -1936,9 +1926,14 @@ PP(pp_subtract) NV nl = SvNVX(svl); NV nr = SvNVX(svr); - il = (IV)nl; - ir = (IV)nr; - if (nl == (NV)il && nr == (NV)ir) + 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--; @@ -2636,6 +2631,8 @@ S_scomplement(pTHX_ SV *targ, SV *sv) 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) { @@ -2769,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; @@ -2793,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). @@ -2816,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) @@ -3201,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); } } } @@ -3578,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, @@ -3600,11 +3547,7 @@ PP(pp_index) temp = little_utf8 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen); - if (IN_ENCODING) { - sv_recode_to_utf8(temp, _get_encoding()); - } else { - sv_utf8_upgrade(temp); - } + sv_utf8_upgrade(temp); if (little_utf8) { big = temp; big_utf8 = TRUE; @@ -3686,13 +3629,6 @@ PP(pp_ord) 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; - } - SETu(DO_UTF8(argsv) ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : (UV)(*s)); @@ -3754,22 +3690,6 @@ 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); - } - } - SETTARG; return NORMAL; } @@ -3859,10 +3779,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, @@ -4102,9 +4019,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) && ( @@ -4361,10 +4276,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)) { @@ -4839,7 +4751,7 @@ 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)++; @@ -4865,7 +4777,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; @@ -4874,12 +4786,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) { + 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); } @@ -4890,6 +4813,7 @@ PP(pp_akeys) PUSHs(elem ? *elem : &PL_sv_undef); } } + } } RETURN; } @@ -4901,7 +4825,7 @@ PP(pp_each) dSP; HV * hash = MUTABLE_HV(POPs); HE *entry; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; entry = hv_iternext(hash); @@ -4925,7 +4849,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); @@ -5035,7 +4959,7 @@ S_do_delete_local(pTHX) PP(pp_delete) { dSP; - I32 gimme; + U8 gimme; I32 discard; if (PL_op->op_private & OPpLVAL_INTRO) @@ -5200,7 +5124,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; } } @@ -5349,41 +5274,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; @@ -5592,7 +5487,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) { @@ -5635,7 +5530,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); @@ -5648,7 +5543,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) { @@ -5838,7 +5733,7 @@ PP(pp_split) 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; @@ -6279,7 +6174,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) @@ -6300,6 +6195,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) { @@ -6338,7 +6245,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; @@ -6370,13 +6277,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; @@ -6421,14 +6354,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; @@ -6441,6 +6370,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; @@ -6677,6 +6615,212 @@ PP(pp_anonconst) 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 + * + * It assumes that the pad var is currently uninitialised, so this op + * should only be used at the start of a sub, where its not possible to + * skip the op (e.g. no 'my $x if $cond' stuff for example). + */ + +PP(pp_argelem) +{ + dTARG; + SV *val; + SV ** padentry; + OP *o = PL_op; + AV *defav = GvAV(PL_defgv); /* @_ */ + UV ix = PTR2UV(cUNOP_AUXo->op_aux); + IV argc; + SV **argv; + + assert(!SvMAGICAL(defav)); + + /* 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 { + /* should already have been checked */ + assert(ix < I32_MAX && AvFILLp(defav) >= (I32)ix); + val = AvARRAY(defav)[ix]; + if (UNLIKELY(!val)) + val = &PL_sv_undef; + } + + /* $var = $val */ + + /* cargo-culted from pp_sassign */ + assert(TAINTING_get || !TAINT_get); + if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) + TAINT_NOT; + + /* Short-cut assignment of IV and RV values as these are + * common and simple. For RVs, it's likely that on + * subsequent calls to a function, targ is already of the + * correct storage class */ + if (LIKELY(!SvMAGICAL(val))) { + /* just an IV */ + if ((SvFLAGS(val) & (SVf_IOK|SVf_NOK|SVf_POK|SVf_IVisUV)) == SVf_IOK) { + IV i = SvIVX(val); + if (LIKELY(SvTYPE(targ) == SVt_IV)) { + assert(!SvOK(targ)); + assert(!SvMAGICAL(targ)); + (void)SvIOK_only(targ); + SvIV_set(targ, i); + } + else + sv_setiv(targ, i); + } + else if (SvROK(val) && SvTYPE(targ) == SVt_IV) { + /* quick ref assignment */ + assert(!SvOK(targ)); + SvRV_set(targ, SvREFCNT_inc(SvRV(val))); + SvROK_on(targ); + } + else + sv_setsv(targ, val); + } + else + sv_setsv(targ, val); + return o->op_next; + } + + /* must be AV or HV */ + + assert(!(o->op_flags & OPf_STACKED)); + argc = ((IV)AvFILLp(defav) + 1) - (IV)ix; + assert(!SvMAGICAL(targ)); + if (argc <= 0) + return o->op_next; + argv = AvARRAY(defav) + ix; + assert(argv); + + /* This is a copy of the relevant parts of pp_aassign(). + * We *know* that @foo / %foo is a plain empty lexical at this point, + * so we can avoid a lot of the extra baggage. + * We know, because all the usual tricks like 'my @a if 0', + * 'foo: my @a = ...; goto foo' can't be done with signatures. + */ + if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) { + UV i = 0; + + assert(AvFILLp((AV*)targ) == -1); /* can skip av_clear() */ + av_extend((AV*)targ, argc); + + while (argc--) { + SV *tmpsv; + SV *arg = *argv++; + tmpsv = newSV(0); + sv_setsv(tmpsv, arg); + av_store((AV*)targ, i++, tmpsv); + TAINT_NOT; + } + + } + else { + assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV); + + assert(argc % 2 == 0); + assert(!HvTOTALKEYS(targ)); /* can skip hv_clear() */ + + while (argc) { + SV *tmpsv; + SV *key = *argv++; + SV *val = *argv++; + + assert(key); assert(val); + 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); /* @_ */ + PADOFFSET ix = o->op_targ; + + assert(!SvMAGICAL(defav)); + assert(ix < I32_MAX); + if (AvFILLp(defav) >= (I32)ix) { + dSP; + XPUSHs(AvARRAY(defav)[ix]); + 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; + UV params = aux[0].uv; + UV opt_params = aux[1].uv; + char slurpy = (char)(aux[2].iv); + AV *defav = GvAV(PL_defgv); /* @_ */ + UV argc; + bool too_few; + + assert(!SvMAGICAL(defav)); + argc = (UV)(AvFILLp(defav) + 1); + too_few = (argc < (params - opt_params)); + + if (UNLIKELY(too_few || (!slurpy && argc > params))) + 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: */