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;
}
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));
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));
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
PUSHs(newsv);
}
else {
- mPUSHi(do_trans(sv));
+ I32 i = do_trans(sv);
+ mPUSHi(i);
}
RETURN;
}
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) {
}
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);
}
-/* 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);
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)
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
{
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;
}
}
if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
- const Size_t items = SP - MARK;
+ const SSize_t items = SP - MARK;
const U8 mod = PL_op->op_flags & OPf_MOD;
if (count > 1) {
- Size_t max;
+ SSize_t max;
- if ( items > MEM_SIZE_MAX / (UV)count /* max would overflow */
- || items > (U32)I32_MAX / sizeof(SV *) /* repeatcpy would overflow */
+ 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;
SP += max;
}
else if (count <= 0)
- SP -= items;
+ SP = MARK;
}
else { /* Note: mark already snarfed by pp_list */
SV * const tmpstr = POPs;
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)) {
} /* Overflow, drop through to NVs. */
}
}
+#else
+ useleft = USE_LEFT(svl);
#endif
{
NV value = SvNV_nomg(svr);
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) {
}
}
-#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;
}
}
-#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).
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)
} 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);
}
}
}
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,
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)) {
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));
*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;
}
/* 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,
SvGETMAGIC(source);
- if ((SvPADTMP(source)
- ||
- (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
+ if ( SvPADTMP(source)
&& !SvREADONLY(source) && SvPOK(source)
&& !DO_UTF8(source)
&& (
* 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;
* 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 */
SvGETMAGIC(source);
- if ( ( SvPADTMP(source)
- || ( SvTEMP(source) && !SvSMAGICAL(source)
- && SvREFCNT(source) == 1 )
- )
+ if ( SvPADTMP(source)
&& !SvREADONLY(source) && SvPOK(source)
&& !DO_UTF8(source)) {
* 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
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);
* 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';
{
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)++;
{
dSP;
AV *array = MUTABLE_AV(POPs);
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
*Perl_av_iter_p(aTHX_ array) = 0;
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);
}
PUSHs(elem ? *elem : &PL_sv_undef);
}
}
+ }
}
RETURN;
}
dSP;
HV * hash = MUTABLE_HV(POPs);
HE *entry;
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
entry = hv_iternext(hash);
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);
PP(pp_delete)
{
dSP;
- I32 gimme;
+ U8 gimme;
I32 discard;
if (PL_op->op_private & OPpLVAL_INTRO)
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;
}
}
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) {
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;
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;
while (length-- > 0)
SvREFCNT_dec(tmparyval[length]);
}
+ if (!*MARK)
+ *MARK = &PL_sv_undef;
}
else
*MARK = &PL_sv_undef;
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) {
/* 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++) {
}
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) {
{
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);
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) {
/* 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) {
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;
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) {
}
-/* 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)
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)
{
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;
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;
: "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;
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;
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:
*/
https://perl5.git.perl.org / perl5.git / blobdiff