SV * const temp = left;
left = right; right = temp;
}
+ else if (PL_op->op_private & OPpASSIGN_STATE) {
+ if (SvPADSTALE(right))
+ SvPADSTALE_off(right);
+ else
+ RETURN; /* ignore assignment */
+ }
if (PL_tainting && PL_tainted && !SvTAINTED(left))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
dPOPTOPssrl;
bool lbyte;
STRLEN rlen;
- const char *rpv = 0;
+ const char *rpv = NULL;
bool rbyte = FALSE;
bool rcopied = FALSE;
XPUSHs(TARG);
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ if (!(PL_op->op_private & OPpPAD_STATE))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_private & OPpDEREF) {
PUTBACK;
vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
ivp = *--SP;
}
iv = SvIVX(ivp);
- if (iv < 0) {
+ if (iv < 0)
/* As uv is a UV, it's >0, so it cannot be == */
SETs(&PL_sv_no);
- RETURN;
- }
- /* we know iv is >= 0 */
- SETs(boolSV((UV)iv == SvUVX(uvp)));
+ else
+ /* we know iv is >= 0 */
+ SETs(boolSV((UV)iv == SvUVX(uvp)));
RETURN;
}
}
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left == right));
+#else
dPOPnv;
SETs(boolSV(TOPn == value));
+#endif
RETURN;
}
}
}
}
}
+ if (PL_op->op_private & OPpASSIGN_STATE) {
+ if (SvPADSTALE(*firstlelem))
+ SvPADSTALE_off(*firstlelem);
+ else
+ RETURN; /* ignore assignment */
+ }
relem = firstrelem;
lelem = firstlelem;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (!mg) {
- sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG, 0);
+#endif
+ mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
+ &PL_vtbl_mglob, NULL, 0);
}
if (rx->startp[0] != -1) {
mg->mg_len = rx->endp[0];
else
mg = NULL;
if (!mg) {
- sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG, 0);
+#endif
+ mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
+ &PL_vtbl_mglob, NULL, 0);
}
if (rx->startp[0] != -1) {
mg->mg_len = rx->endp[0];
continue;
}
} else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
- const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
- const STRLEN len = SvCUR(sv) - offset;
- const U8 *f;
-
- if (ckWARN(WARN_UTF8) &&
- !is_utf8_string_loc(s, len, &f))
- /* Emulate :encoding(utf8) warning in the same case. */
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "utf8 \"\\x%02X\" does not map to Unicode",
- f < (U8*)SvEND(sv) ? *f : 0);
+ if (ckWARN(WARN_UTF8)) {
+ const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
+ const STRLEN len = SvCUR(sv) - offset;
+ const U8 *f;
+
+ if (!is_utf8_string_loc(s, len, &f))
+ /* Emulate :encoding(utf8) warning in the same case. */
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "utf8 \"\\x%02X\" does not map to Unicode",
+ f < (U8*)SvEND(sv) ? *f : 0);
+ }
}
if (gimme == G_ARRAY) {
if (SvLEN(sv) - SvCUR(sv) > 20) {
const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
I32 preeminent = 0;
- if (SvTYPE(hv) == SVt_PVHV) {
- if (PL_op->op_private & OPpLVAL_INTRO) {
- MAGIC *mg;
- HV *stash;
- /* does the element we're localizing already exist? */
- preeminent =
- /* can we determine whether it exists? */
- ( !SvRMAGICAL(hv)
- || mg_find((SV*)hv, PERL_MAGIC_env)
- || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
- /* Try to preserve the existenceness of a tied hash
- * element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise */
- && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
- && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
- && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
- )
- ) ? hv_exists_ent(hv, keysv, 0) : 1;
-
- }
- he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
- svp = he ? &HeVAL(he) : NULL;
- }
- else {
+ if (SvTYPE(hv) != SVt_PVHV)
RETPUSHUNDEF;
- }
+
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ MAGIC *mg;
+ HV *stash;
+ /* does the element we're localizing already exist? */
+ preeminent = /* can we determine whether it exists? */
+ ( !SvRMAGICAL(hv)
+ || mg_find((SV*)hv, PERL_MAGIC_env)
+ || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
+ /* Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise */
+ && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
+ && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
+ && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
+ )
+ ) ? hv_exists_ent(hv, keysv, 0) : 1;
+ }
+ he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
+ svp = he ? &HeVAL(he) : NULL;
if (lval) {
if (!svp || *svp == &PL_sv_undef) {
SV* lv;
if (!preeminent) {
STRLEN keylen;
const char * const key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
+ SAVEDELETE(hv, savepvn(key,keylen),
+ SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
} else
save_helem(hv, keysv, svp);
}
/* string increment */
register SV* cur = cx->blk_loop.iterlval;
STRLEN maxlen = 0;
- const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
+ const char *max =
+ SvOK((SV*)av) ?
+ SvPV_const((SV*)av, maxlen) : (const char *)"";
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
#endif
rxtainted |= RX_MATCH_TAINTED(rx);
dstr = newSVpvn(m, s-m);
+ SAVEFREESV(dstr);
if (DO_UTF8(TARG))
SvUTF8_on(dstr);
PL_curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
SPAGAIN;
- (void)ReREFCNT_inc(rx);
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplroot);
}
SvLEN_set(TARG, SvLEN(dstr));
doutf8 |= DO_UTF8(dstr);
SvPV_set(dstr, NULL);
- sv_free(dstr);
TAINT_IF(rxtainted & 1);
SPAGAIN;
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
if (SvTEMP(*mark))
- /*EMPTY*/;
+ NOOP;
else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
*mark = sv_mortalcopy(*mark);
else {
save_item(dbsv);
if (!PERLDB_SUB_NN) {
- GV *gv = CvGV(cv);
+ GV * const gv = CvGV(cv);
if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
|| ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
- !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
- && (gv = (GV*)*svp) ))) {
+ !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
SV * const tmp = newRV((SV*)cv);
else {
sub_name = sv_newmortal();
gv_efullname3(sub_name, gv, NULL);
- DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
}
}
if (!cv)
}
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (hasargs)
- {
+ if (hasargs) {
AV* const av = (AV*)PAD_SVl(0);
if (AvREAL(av)) {
/* @_ is normally not REAL--this should only ever
RETURNOP(CvSTART(cv));
}
else {
- I32 markix = TOPMARK;
+ I32 markix = TOPMARK;
- PUTBACK;
+ PUTBACK;
- if (!hasargs) {
- /* Need to copy @_ to stack. Alternative may be to
- * switch stack to @_, and copy return values
- * back. This would allow popping @_ in XSUB, e.g.. XXXX */
- AV * const av = GvAV(PL_defgv);
- const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
-
- if (items) {
- /* Mark is at the end of the stack. */
- EXTEND(SP, items);
- Copy(AvARRAY(av), SP + 1, items, SV*);
- SP += items;
- PUTBACK ;
- }
- }
- /* We assume first XSUB in &DB::sub is the called one. */
- if (PL_curcopdb) {
- SAVEVPTR(PL_curcop);
- PL_curcop = PL_curcopdb;
- PL_curcopdb = NULL;
- }
- /* Do we need to open block here? XXXX */
+ if (!hasargs) {
+ /* Need to copy @_ to stack. Alternative may be to
+ * switch stack to @_, and copy return values
+ * back. This would allow popping @_ in XSUB, e.g.. XXXX */
+ AV * const av = GvAV(PL_defgv);
+ const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
+
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(SP, items);
+ Copy(AvARRAY(av), SP + 1, items, SV*);
+ SP += items;
+ PUTBACK ;
+ }
+ }
+ /* We assume first XSUB in &DB::sub is the called one. */
+ if (PL_curcopdb) {
+ SAVEVPTR(PL_curcop);
+ PL_curcop = PL_curcopdb;
+ PL_curcopdb = NULL;
+ }
+ /* Do we need to open block here? XXXX */
+ if (CvXSUB(cv)) /* XXX this is supposed to be true */
(void)(*CvXSUB(cv))(aTHX_ cv);
- /* Enforce some sanity in scalar context. */
- if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
- if (markix > PL_stack_sp - PL_stack_base)
- *(PL_stack_base + markix) = &PL_sv_undef;
- else
- *(PL_stack_base + markix) = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + markix;
- }
+ /* Enforce some sanity in scalar context. */
+ if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
+ if (markix > PL_stack_sp - PL_stack_base)
+ *(PL_stack_base + markix) = &PL_sv_undef;
+ else
+ *(PL_stack_base + markix) = *PL_stack_sp;
+ PL_stack_sp = PL_stack_base + markix;
+ }
LEAVE;
return NORMAL;
}
SV* const tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), NULL);
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
- tmpstr);
+ (void*)tmpstr);
}
}
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Use of reference \"%"SVf"\" as array index",
+ (void*)elemsv);
if (elem > 0)
- elem -= PL_curcop->cop_arybase;
+ elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
svp = av_fetch(av, elem, lval && !defer);
if (!stash)
packsv = sv;
else {
- SV* ref = newSViv(PTR2IV(stash));
+ SV* const ref = newSViv(PTR2IV(stash));
hv_store(PL_stashcache, packname, packlen, ref, 0);
}
goto fetch;