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 == 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 == 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));
PP(pp_clonecv)
{
dTARGET;
- MAGIC * const mg =
- mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
- PERL_MAGIC_proto);
+ CV * const protocv = PadnamePROTOCV(
+ PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
+ );
assert(SvTYPE(TARG) == SVt_PVCV);
- assert(mg);
- assert(mg->mg_obj);
- if (CvISXSUB(mg->mg_obj)) { /* constant */
+ assert(protocv);
+ if (CvISXSUB(protocv)) { /* constant */
/* XXX Should we clone it here? */
/* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
to introcv and remove the SvPADSTALE_off. */
SAVEPADSVANDMORTALIZE(ARGTARG);
- PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
+ PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
}
else {
- if (CvROOT(mg->mg_obj)) {
- assert(CvCLONE(mg->mg_obj));
- assert(!CvCLONED(mg->mg_obj));
+ if (CvROOT(protocv)) {
+ assert(CvCLONE(protocv));
+ assert(!CvCLONED(protocv));
}
- cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
+ cv_clone_into(protocv,(CV *)TARG);
SAVECLEARSV(PAD_SVl(ARGTARG));
}
return NORMAL;
/* Translations. */
-static const char S_no_symref_sv[] =
- "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
-
/* In some cases this function inspects PL_op. If this function is called
for new op types, more bool parameters may need to be added in place of
the checks.
else {
if (strict) {
Perl_die(aTHX_
- S_no_symref_sv,
+ PL_no_symref_sv,
sv,
(SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
"a symbol"
if (PL_op->op_private & HINT_STRICT_REFS) {
if (SvOK(sv))
- Perl_die(aTHX_ S_no_symref_sv, sv,
+ Perl_die(aTHX_ PL_no_symref_sv, sv,
(SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
else
Perl_die(aTHX_ PL_no_usym, what);
}
sv = SvRV(sv);
- switch (SvTYPE(sv)) {
- case SVt_PVAV:
- case SVt_PVHV:
- case SVt_PVCV:
- case SVt_PVFM:
- case SVt_PVIO:
+ if (SvTYPE(sv) >= SVt_PVAV)
DIE(aTHX_ "Not a SCALAR reference");
- default: NOOP;
- }
}
else {
gv = MUTABLE_GV(sv);
PP(pp_pos)
{
- dSP; dPOPss;
+ dSP; dTOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
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;
+ SETs(ret); /* no SvSETMAGIC */
}
else {
const MAGIC * const mg = mg_find_mglob(sv);
STRLEN i = mg->mg_len;
if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
- PUSHu(i);
- RETURN;
+ SETu(i);
+ return NORMAL;
}
- RETPUSHUNDEF;
+ SETs(&PL_sv_undef);
}
+ return NORMAL;
}
PP(pp_rv2cv)
else
cv = MUTABLE_CV(&PL_sv_undef);
SETs(MUTABLE_SV(cv));
- RETURN;
+ return NORMAL;
}
PP(pp_prototype)
{
dSP;
*SP = refto(*SP);
- RETURN;
+ return NORMAL;
}
PP(pp_refgen)
{
dSP; dMARK;
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP;
else
+ {
+ MEXTEND(SP, 1);
*MARK = &PL_sv_undef;
+ }
*MARK = refto(*MARK);
SP = MARK;
RETURN;
SV *sv = POPs;
STRLEN len;
const char * const elem = SvPV_const(sv, len);
- GV * const gv = MUTABLE_GV(POPs);
+ GV * const gv = MUTABLE_GV(TOPs);
SV * tmpRef = NULL;
sv = NULL;
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
sv_2mortal(sv);
else
sv = &PL_sv_undef;
- XPUSHs(sv);
+ SETs(sv);
RETURN;
}
PP(pp_study)
{
- dSP; dPOPss;
+ dSP; dTOPss;
STRLEN len;
(void)SvPV(sv, len);
if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
/* Historically, study was skipped in these cases. */
- RETPUSHNO;
+ SETs(&PL_sv_no);
+ return NORMAL;
}
/* Make study a no-op. It's no longer useful and its existence
complicates matters elsewhere. */
- RETPUSHYES;
+ SETs(&PL_sv_yes);
+ return NORMAL;
}
PP(pp_trans)
{
- dSP; dTARG;
+ dSP;
SV *sv;
if (PL_op->op_flags & OPf_STACKED)
sv = POPs;
- else if (ARGTARG)
- sv = GETTARGET;
else {
- sv = DEFSV;
EXTEND(SP,1);
+ if (ARGTARG)
+ sv = PAD_SV(ARGTARG);
+ else {
+ sv = DEFSV;
+ }
}
if(PL_op->op_type == OP_TRANSR) {
STRLEN len;
PUSHs(newsv);
}
else {
- TARG = sv_newmortal();
- PUSHi(do_trans(sv));
+ I32 i = do_trans(sv);
+ mPUSHi(i);
}
RETURN;
}
Perl_croak_no_modify();
}
- if (PL_encoding) {
+ 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, PL_encoding);
+ 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;
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 (PL_encoding) {
+ 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, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
rsptr = SvPV_const(svrecode, rslen);
rs_charlen = sv_len_utf8(svrecode);
}
}
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;
}
}
*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);
if (chomping)
sv_setiv(TARG, count);
SETTARG;
- RETURN;
+ return NORMAL;
}
RETPUSHUNDEF;
}
- sv = POPs;
+ sv = TOPs;
if (!sv)
- RETPUSHUNDEF;
+ {
+ SETs(&PL_sv_undef);
+ return NORMAL;
+ }
if (SvTHINKFIRST(sv))
sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
SvSETMAGIC(sv);
}
- RETPUSHUNDEF;
+ SETs(&PL_sv_undef);
+ return NORMAL;
}
-/* 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
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) {
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);
}
}
/* 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. */
/* 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. */
}
{
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;
}
}
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"
left_non_neg = TRUE; /* effectively it's a UV now */
}
else {
- left = -aiv;
+ left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
}
}
}
/* 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 );
right = biv;
right_neg = FALSE; /* effectively it's a UV now */
} else {
- right = -biv;
+ right = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
}
}
}
left = aiv;
left_neg = FALSE; /* effectively it's a UV now */
} else {
- left = -aiv;
+ left = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
}
}
}
dSP; dATARGET;
IV count;
SV *sv;
+ bool infnan = FALSE;
- if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
+ if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
/* TODO: think of some way of doing list-repeat overloading ??? */
sv = POPs;
SvGETMAGIC(sv);
}
}
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 == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
+ 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)) {
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);
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);
}
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)) {
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;
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.
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 );
} /* Overflow, drop through to NVs. */
}
}
+#else
+ useleft = USE_LEFT(svl);
#endif
{
NV value = SvNV_nomg(svr);
}
}
+#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;
{
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;
}
{
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;
}
return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
}
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
#endif
{
}
}
+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() */
}
}
+/* 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)
{
*SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
}
else return FALSE;
- SETTARG; PUTBACK;
+ SETTARG;
return TRUE;
}
/* 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
}
else
SETn(-SvNV_nomg(sv));
}
- RETURN;
+ return NORMAL;
}
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;
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++;
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) {
sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
SvUTF8_off(TARG);
}
- SETTARG;
- RETURN;
+ return;
}
#ifdef LIBERAL
{
#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;
}
}
}
}
-#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
-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)
-STATIC
-PP(pp_i_modulo_1)
+#if defined(__GLIBC__) && IVSIZE == 8 \
+ && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
+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 glicb 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)
SV * const sv = TOPs;
IV const i = SvIV_nomg(sv);
SETi(-i);
- RETURN;
+ return NORMAL;
}
}
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 */
case OP_LOG: result = Perl_log(value); break;
case OP_SQRT: result = Perl_sqrt(value); break;
}
- XPUSHn(result);
- RETURN;
+ SETn(result);
+ return NORMAL;
}
}
{
dSP;
NV value;
- EXTEND(SP, 1);
if (MAXARG < 1)
+ {
+ EXTEND(SP, 1);
value = 1.0;
+ }
else {
SV * const sv = POPs;
if(!sv)
}
else {
const NV value = SvNV_nomg(sv);
- if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
- SETn(SvNV(sv));
+ if (UNLIKELY(Perl_isinfnan(value)))
+ SETn(value);
else if (value >= 0.0) {
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
}
}
}
- RETURN;
+ return NORMAL;
}
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);
}
}
}
SETn(value);
}
}
- RETURN;
+ return NORMAL;
}
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)) {
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. */
/* simplest case shortcut */
/* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
- assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
+ STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
SETs(TARG);
if(LIKELY(svflags == SVf_POK))
assert(!repl_sv);
repl_sv = POPs;
}
- PUTBACK;
if (lvalue && !repl_sv) {
SV * ret;
ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
? (STRLEN)(UV)len_iv
: (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
- SPAGAIN;
PUSHs(ret); /* avoid SvSETMAGIC here */
RETURN;
}
SvREFCNT_dec(repl_sv_copy);
}
}
- SPAGAIN;
if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
SP++;
else if (rvalue) {
}
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");
little_utf8 = DO_UTF8(little);
if (big_utf8 ^ little_utf8) {
/* One needs to be upgraded. */
- if (little_utf8 && !PL_encoding) {
+ if (little_utf8 && !IN_ENCODING) {
/* Well, maybe instead we might be able to downgrade the small
string? */
char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
temp = little_utf8
? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
- if (PL_encoding) {
- sv_recode_to_utf8(temp, PL_encoding);
+ if (IN_ENCODING) {
+ sv_recode_to_utf8(temp, _get_encoding());
} else {
sv_utf8_upgrade(temp);
}
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,
retval = -1;
else {
retval = little_p - big_p;
- if (retval > 0 && big_utf8)
+ if (retval > 1 && big_utf8)
retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
}
SvREFCNT_dec(temp);
{
dSP; dTARGET;
- SV *argsv = POPs;
+ SV *argsv = TOPs;
STRLEN len;
const U8 *s = (U8*)SvPV_const(argsv, len);
- if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
+ if (IN_ENCODING && SvPOK(argsv) && !DO_UTF8(argsv)) {
SV * const tmpsv = sv_2mortal(newSVsv(argsv));
- s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
+ 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)
dSP; dTARGET;
char *tmps;
UV value;
- SV *top = POPs;
+ SV *top = TOPs;
SvGETMAGIC(top);
+ if (UNLIKELY(SvAMAGIC(top)))
+ top = sv_2num(top);
if (UNLIKELY(isinfnansv(top)))
Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
else {
&& ((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();
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);
*tmps = '\0';
(void)SvPOK_only(TARG);
- if (PL_encoding && !IN_BYTES) {
- sv_recode_to_utf8(TARG, PL_encoding);
+ 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))
}
}
- XPUSHTARG;
- RETURN;
+ SETTARG;
+ return NORMAL;
}
PP(pp_crypt)
/* If Unicode, try to downgrade.
* If not possible, croak.
* Yes, we made this up. */
- SV* const tsv = sv_2mortal(newSVsv(left));
+ SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
- SvUTF8_on(tsv);
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPV_const(tsv, len);
}
# else
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
# endif
+ SvUTF8_off(TARG);
SETTARG;
RETURN;
#else
/* 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,
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 */
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
SvGETMAGIC(source);
- if ((SvPADTMP(source)
- ||
- (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
+ if ( SvPADTMP(source)
&& !SvREADONLY(source) && SvPOK(source)
&& !DO_UTF8(source)
&& (
if (IN_UTF8_CTYPE_LOCALE) {
goto do_uni_rules;
}
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
for (; s < send; d++, s++)
*d = (U8) toUPPER_LC(*s);
}
* 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
*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
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
- RETURN;
+ return NORMAL;
}
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)) {
* 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);
}
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
- RETURN;
+ return NORMAL;
}
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;
}
else
sv_setpvn(TARG, s, len);
SETTARG;
- RETURN;
+ return NORMAL;
}
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 )
if (IN_UTF8_CTYPE_LOCALE) {
goto do_uni_folding;
}
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
for (; s < send; d++, s++)
*d = (U8) toFOLD_LC(*s);
}
*MARK = svp ? *svp : &PL_sv_undef;
}
}
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
MARK = ORIGMARK;
*++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
SP = MARK;
}
*++MARK = svp ? *svp : &PL_sv_undef;
}
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
MARK = SP - items*2;
*++MARK = items > 0 ? *SP : &PL_sv_undef;
SP = MARK;
}
-/* 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)++;
{
dSP;
AV *array = MUTABLE_AV(POPs);
- const I32 gimme = GIMME_V;
+ const U8 gimme = GIMME_V;
*Perl_av_iter_p(aTHX_ array) = 0;
EXTEND(SP, n + 1);
- if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
+ if (PL_op->op_type == OP_AKEYS) {
for (i = 0; i <= n; i++) {
mPUSHi(i);
}
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);
}
}
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)
}
*MARK = svp && *svp ? *svp : &PL_sv_undef;
}
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
MARK = ORIGMARK;
*++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
SP = MARK;
}
*++MARK = svp && *svp ? *svp : &PL_sv_undef;
}
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
MARK = SP - items*2;
*++MARK = items > 0 ? *SP : &PL_sv_undef;
SP = MARK;
PP(pp_list)
{
I32 markidx = POPMARK;
- if (GIMME != G_ARRAY) {
+ if (GIMME_V != G_ARRAY) {
SV **mark = PL_stack_base + markidx;
dSP;
if (++MARK <= SP)
SV ** const lastlelem = PL_stack_base + POPMARK;
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
SV ** const firstrelem = lastlelem + 1;
- I32 is_something_there = FALSE;
const U8 mod = PL_op->op_flags & OPf_MOD;
const I32 max = lastrelem - lastlelem;
SV **lelem;
- if (GIMME != 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 (GIMME_V != G_ARRAY) {
+ 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) {
if (ix < 0 || ix >= max)
*lelem = &PL_sv_undef;
else {
- is_something_there = TRUE;
if (!(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
else if (mod && SvPADTMP(*lelem)) {
}
}
}
- if (is_something_there)
- SP = lastlelem;
- else
- SP = firstlelem - 1;
+ SP = lastlelem;
RETURN;
}
MARK++;
SvGETMAGIC(*MARK);
val = newSV(0);
- sv_setsv(val, *MARK);
+ sv_setsv_nomg(val, *MARK);
}
else
{
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;
}
MARK = ORIGMARK + 1;
- if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
const bool real = cBOOL(AvREAL(ary));
MEXTEND(MARK, length);
if (real)
}
MARK = ORIGMARK + 1;
- if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
if (length) {
const bool real = cBOOL(AvREAL(ary));
if (real)
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) {
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++) {
}
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(GvAV(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) {
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) {
{
dSP; dMARK;
- if (GIMME == G_ARRAY) {
+ if (GIMME_V == G_ARRAY) {
if (PL_op->op_private & OPpREVERSE_INPLACE) {
AV *av;
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);
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;
#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);
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) {
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;
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;
);
PUSHs(SvRV(*svp));
if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
- && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
+ && CX_CUR()->cx_type & CXp_HASARGS) {
/* 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));
+ PERL_CONTEXT *cx = CX_CUR();
+
+ assert(CxHASARGS(cx));
+ cx_popsub_args(cx);;
+ cx->cx_type &= ~CXp_HASARGS;
}
}
break;
if (bad)
/* diag_listed_as: Assigned value is not %s reference */
DIE(aTHX_ "Assigned value is not a%s reference", bad);
+ {
+ MAGIC *mg;
+ HV *stash;
switch (left ? SvTYPE(left) : 0) {
- MAGIC *mg;
- HV *stash;
case 0:
{
SV * const old = PAD_SV(ARGTARG);
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));
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));
- hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
+ }
+ (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
}
if (PL_op->op_flags & OPf_MOD)
SETs(sv_2mortal(newSVsv(sv)));
/* XXX else can weak references go stale before they are read, e.g.,
in leavesub? */
RETURN;
+ }
}
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,
}
}
+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;
+}
+
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff