} else if (PL_op->op_private & OPpMAYBE_LVSUB) {
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (GIMME == G_SCALAR)
+ 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);
else if (PL_op->op_private & OPpMAYBE_LVSUB) {
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (GIMME == G_SCALAR)
+ 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;
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);
AV * const av = MUTABLE_AV(TOPs);
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
if (lvalue) {
- SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
- if (!*sv) {
- *sv = newSV_type(SVt_PVMG);
- sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
+ SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
+ if (!*svp) {
+ *svp = newSV_type(SVt_PVMG);
+ sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
}
- SETs(*sv);
+ SETs(*svp);
} else {
SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
}
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;
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 (PL_op->op_private & OPpTARGET_MY)
- 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));
+ mPUSHi(do_trans(sv));
}
RETURN;
}
/* Lvalue operators. */
-static void
+static size_t
S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
{
STRLEN len;
char *s;
+ size_t count = 0;
PERL_ARGS_ASSERT_DO_CHOMP;
if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
- return;
+ return 0;
if (SvTYPE(sv) == SVt_PVAV) {
I32 i;
AV *const av = MUTABLE_AV(sv);
for (i = 0; i <= max; i++) {
sv = MUTABLE_SV(av_fetch(av, i, FALSE));
if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
- do_chomp(retval, sv, chomping);
+ count += do_chomp(retval, sv, chomping);
}
- return;
+ return count;
}
else if (SvTYPE(sv) == SVt_PVHV) {
HV* const hv = MUTABLE_HV(sv);
HE* entry;
(void)hv_iterinit(hv);
while ((entry = hv_iternext(hv)))
- do_chomp(retval, hv_iterval(hv,entry), chomping);
- return;
+ count += do_chomp(retval, hv_iterval(hv,entry), chomping);
+ return count;
}
else if (SvREADONLY(sv)) {
Perl_croak_no_modify();
}
- else if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
- 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());
}
}
if (RsPARA(PL_rs)) {
if (*s != '\n')
goto nope;
- ++SvIVX(retval);
+ ++count;
while (len && s[-1] == '\n') {
--len;
--s;
- ++SvIVX(retval);
+ ++count;
}
}
else {
}
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;
- ++SvIVX(retval);
+ ++count;
}
else {
if (len < rslen - 1)
s -= rslen - 1;
if (memNE(s, rsptr, rslen))
goto nope;
- SvIVX(retval) += rs_charlen;
+ count += rs_charlen;
}
}
- s = SvPV_force_nomg_nolen(sv);
+ SvPV_force_nomg_nolen(sv);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
SvNIOK_off(sv);
Safefree(temp_buffer);
} else {
- if (len && !SvPOK(sv))
+ if (len && (!SvPOK(sv) || SvIsCOW(sv)))
s = SvPV_force_nomg(sv, len);
if (DO_UTF8(sv)) {
if (s && len) {
sv_setpvs(retval, "");
SvSETMAGIC(sv);
}
+ return count;
}
dSP; dTARGET;
const bool chomping = PL_op->op_type == OP_SCHOMP;
+ const size_t count = do_chomp(TARG, TOPs, chomping);
if (chomping)
- sv_setiv(TARG, 0);
- do_chomp(TARG, TOPs, chomping);
+ sv_setiv(TARG, count);
SETTARG;
- RETURN;
+ return NORMAL;
}
{
dSP; dMARK; dTARGET; dORIGMARK;
const bool chomping = PL_op->op_type == OP_CHOMP;
+ size_t count = 0;
- if (chomping)
- sv_setiv(TARG, 0);
while (MARK < SP)
- do_chomp(TARG, *++MARK, chomping);
+ count += do_chomp(TARG, *++MARK, chomping);
+ if (chomping)
+ sv_setiv(TARG, count);
SP = ORIGMARK;
XPUSHTARG;
RETURN;
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;
}
/* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (inc && !SvOK(TARG))
sv_setiv(TARG, 0);
- SETs(TARG);
+ SETTARG;
return NORMAL;
}
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. */
}
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 (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
+ /* The parser saw this as a list repeat, and there
+ are probably several items on the stack. But we're
+ in scalar/void context, and there's no pp_list to save us
+ now. So drop the rest of the items -- robin@kitsite.com
+ */
+ dMARK;
+ if (MARK + 1 < SP) {
+ MARK[1] = TOPm1s;
+ MARK[2] = TOPs;
+ }
+ else {
+ dTOPss;
+ ASSUME(MARK + 1 == SP);
+ XPUSHs(sv);
+ MARK[1] = &PL_sv_undef;
+ }
+ SP = MARK + 2;
+ }
tryAMAGICbin_MG(repeat_amg, AMGf_assign);
sv = POPs;
}
}
}
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;
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
-#if 0
- /* This code was intended to fix 20010809.028:
-
- $x = 'abcd';
- for (($x =~ /./g) x 2) {
- print chop; # "abcdabcd" expected as output.
- }
-
- * but that change (#11635) broke this code:
-
- $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
-
- * I can't think of a better fix that doesn't introduce
- * an efficiency hit by copying the SVs. The stack isn't
- * refcounted, and mortalisation obviously doesn't
- * Do The Right Thing when the stack has more than
- * one pointer to the same mortal value.
- * .robin.
- */
- if (*SP) {
- *SP = sv_2mortal(newSVsv(*SP));
- SvREADONLY_on(*SP);
- }
-#else
if (*SP) {
if (mod && SvPADTMP(*SP)) {
*SP = sv_mortalcopy(*SP);
}
SvTEMP_off((*SP));
}
-#endif
SP--;
}
MARK++;
else
(void)SvPOK_only(TARG);
- if (PL_op->op_private & OPpREPEAT_DOLIST) {
- /* The parser saw this as a list repeat, and there
- are probably several items on the stack. But we're
- in scalar context, and there's no pp_list to save us
- now. So drop the rest of the items -- robin@kitsite.com
- */
- dMARK;
- SP = MARK;
- }
PUSHTARG;
}
RETURN;
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 );
return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
}
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
#endif
{
*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)
SvUTF8_off(TARG);
}
SETTARG;
- RETURN;
+ return NORMAL;
}
#ifdef LIBERAL
{
*tmps = ~*tmps;
SETTARG;
}
- RETURN;
+ return NORMAL;
}
}
}
}
-#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
+#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
+ && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
STATIC
PP(pp_i_modulo_0)
#else
}
}
-#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
+#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) \
+ && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
STATIC
PP(pp_i_modulo_1)
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
+ * (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
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)
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 (rvalue) {
+ if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
+ SP++;
+ else if (rvalue) {
SvSETMAGIC(TARG);
PUSHs(TARG);
}
}
sv_setuv(ret, do_vecget(src, offset, size));
+ if (!lvalue)
+ SvSETMAGIC(ret);
PUSHs(ret);
RETURN;
}
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);
}
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 {
*tmps = '\0';
(void)SvPOK_only(TARG);
SvUTF8_on(TARG);
- XPUSHs(TARG);
- 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))
}
}
- XPUSHs(TARG);
- 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
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
if (IN_UTF8_CTYPE_LOCALE) {
goto do_uni_rules;
}
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
for (; s < send; d++, s++)
*d = (U8) toUPPER_LC(*s);
}
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
- RETURN;
+ return NORMAL;
}
PP(pp_lc)
* 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)
else
sv_setpvn(TARG, s, len);
SETTARG;
- RETURN;
+ return NORMAL;
}
PP(pp_fc)
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;
HE *entry;
const I32 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);
}
}
}
*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) {
+ if (GIMME_V != G_ARRAY) {
I32 ix = SvIV(*lastlelem);
if (ix < 0)
ix += max;
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
{
}
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)
{
dSP; dMARK;
- if (GIMME == G_ARRAY) {
+ if (GIMME_V == G_ARRAY) {
if (PL_op->op_private & OPpREVERSE_INPLACE) {
AV *av;
PP(pp_split)
{
dSP; dTARG;
- AV *ary;
+ AV *ary = PL_op->op_flags & OPf_STACKED ? (AV *)POPs : NULL;
IV limit = POPi; /* note, negative is forever */
SV * const sv = POPs;
STRLEN len;
#else
pm = (PMOP*)POPs;
#endif
- if (!pm || !s)
+ if (!pm)
DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
rx = PM_GETRE(pm);
#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
- ary = NULL;
+ else if (pm->op_targ)
+ ary = (AV *)PAD_SVl(pm->op_targ);
if (ary) {
+ have_av:
realarray = 1;
PUTBACK;
av_extend(ary,0);
+ (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
av_clear(ary);
SPAGAIN;
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
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);
PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
SvREFCNT_dec(old);
- if (PL_op->op_private & OPpLVAL_INTRO)
+ if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+ == OPpLVAL_INTRO)
SAVECLEARSV(PAD_SVl(ARGTARG));
break;
}
if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
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)
SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
&PL_vtbl_lvref, (char *)elem,
- elem ? HEf_SVKEY : ARGTARG);
+ elem ? HEf_SVKEY : (I32)ARGTARG);
mg->mg_private = PL_op->op_private;
+ if (PL_op->op_private & OPpLVREF_ITER)
+ mg->mg_flags |= MGf_PERSIST;
if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
if (elem) {
MAGIC *mg;
S_localise_gv_slot(aTHX_ (GV *)arg,
PL_op->op_private & OPpLVREF_TYPE);
}
- else
+ else if (!(PL_op->op_private & OPpPAD_STATE))
SAVECLEARSV(PAD_SVl(ARGTARG));
}
XPUSHs(ret);
https://perl5.git.perl.org / perl5.git / blobdiff