PP(pp_sassign)
{
- dVAR; dSP; dPOPTOPssrl;
+ dVAR; dSP;
+ /* sassign keeps its args in the optree traditionally backwards.
+ So we pop them differently.
+ */
+ SV *left = POPs; SV *right = TOPs;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
SV * const temp = left;
left = right; right = temp;
}
- if (PL_tainting && PL_tainted && !SvTAINTED(left))
+ if (PL_tainting && PL_tainted && !SvTAINTED(right))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
- SV * const cv = SvRV(left);
+ SV * const cv = SvRV(right);
const U32 cv_type = SvTYPE(cv);
- const bool is_gv = isGV_with_GP(right);
+ const bool is_gv = isGV_with_GP(left);
const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
if (!got_coderef) {
assert(SvROK(cv));
}
- /* Can do the optimisation if right (LVALUE) is not a typeglob,
- left (RVALUE) is a reference to something, and we're in void
+ /* Can do the optimisation if left (LVALUE) is not a typeglob,
+ right (RVALUE) is a reference to something, and we're in void
context. */
if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
/* Is the target symbol table currently empty? */
- GV * const gv = gv_fetchsv_nomg(right, GV_NOINIT, SVt_PVGV);
+ GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
/* Good. Create a new proxy constant subroutine in the target.
The gv becomes a(nother) reference to the constant. */
SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
- SETs(right);
+ SETs(left);
RETURN;
}
}
/* Need to fix things up. */
if (!is_gv) {
/* Need to fix GV. */
- right = MUTABLE_SV(gv_fetchsv_nomg(right,GV_ADD, SVt_PVGV));
+ left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
}
if (!got_coderef) {
all sorts of fun as the reference to our new sub is
donated to the GV that we're about to assign to.
*/
- SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
+ SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
SvRV(cv))));
SvREFCNT_dec(cv);
LEAVE_with_name("sassign_coderef");
SvREFCNT_inc_void(source);
SvREFCNT_dec(upgraded);
- SvRV_set(left, MUTABLE_SV(source));
+ SvRV_set(right, MUTABLE_SV(source));
}
}
}
if (
- SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
- (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
+ SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
+ (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
)
Perl_warner(aTHX_
packWARN(WARN_MISC), "Useless assignment to a temporary"
);
- SvSetMagicSV(right, left);
- SETs(right);
+ SvSetMagicSV(left, right);
+ SETs(left);
RETURN;
}
unsigned code below is actually shorter than the old code. :-)
*/
- SvIV_please_nomg(svr);
-
- if (SvIOK(svr)) {
+ 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
we know the left is integer. */
lots of code to speed up what is probably a rarish case. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
else {
REGEXP * rx = PM_GETRE(pm);
SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
SV * const rv = sv_newmortal();
+ CV **cvp;
+ CV *cv;
SvUPGRADE(rv, SVt_IV);
/* For a subroutine describing itself as "This is a hacky workaround" I'm
SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
SvROK_on(rv);
+ cvp = &( ((struct regexp*)SvANY(SvRV(rv)))->qr_anoncv);
+ if ((cv = *cvp) && CvCLONE(*cvp)) {
+ *cvp = cv_clone(cv);
+ SvREFCNT_dec(cv);
+ }
+
if (pkg) {
HV *const stash = gv_stashsv(pkg, GV_ADD);
SvREFCNT_dec(pkg);
pm->op_pmflags & PMf_USED
#endif
) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
failure:
+
if (gimme == G_ARRAY)
RETURN;
RETPUSHNO;
rx = PM_GETRE(pm);
}
- if (RX_MINLEN(rx) > (I32)len)
+ if (RX_MINLEN(rx) > (I32)len) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
goto failure;
+ }
truebase = t = s;
play_it_again:
if (global && RX_OFFS(rx)[0].start != -1) {
t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
- if ((s + RX_MINLEN(rx)) > strend || s < truebase)
+ if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
goto nope;
+ }
if (update_minmatch++)
minmatch = had_zerolen;
}
RX_OFFS(rx)[0].start = s - truebase;
RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
}
- /* including RX_NPARENS(rx) in the below code seems highly suspicious.
- -dmq */
- RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
+ /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
+ assert(!RX_NPARENS(rx));
+ RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
LEAVE_SCOPE(oldsave);
RETPUSHYES;
}
}
for (t1 = SvPVX_const(sv); *t1; t1++)
- if (!isALPHA(*t1) && !isDIGIT(*t1) &&
+ if (!isALNUMC(*t1) &&
strchr("$&*(){}[]'\";\\|?<>~`", *t1))
break;
if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
/* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
+ sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
}
else
{
* completely new SV for closures/references to work as they
* used to */
oldsv = *itersvp;
- *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
+ *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
SvREFCNT_dec(oldsv);
}
- /* Handle end of range at IV_MAX */
- if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
- (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
- {
- cx->blk_loop.state_u.lazyiv.cur++;
- cx->blk_loop.state_u.lazyiv.end++;
- }
+ if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
+ /* Handle end of range at IV_MAX */
+ cx->blk_loop.state_u.lazyiv.end = IV_MIN;
+ } else
+ ++cx->blk_loop.state_u.lazyiv.cur;
RETPUSHYES;
}
}
d = s;
PL_curpm = pm;
- SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
https://perl5.git.perl.org / perl5.git / blobdiff