{
dVAR;
dSP;
- if ( PL_op->op_flags & OPf_SPECIAL )
- /* This is a const op added to hold the hints hash for
- pp_entereval. The hash can be modified by the code
- being eval'ed, so we return a copy instead. */
- XPUSHs(sv_2mortal((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv)));
- else
- /* Normal const. */
- XPUSHs(cSVOP_sv);
+ XPUSHs(cSVOP_sv);
RETURN;
}
return NORMAL;
}
-PP(pp_setstate)
-{
- dVAR;
- PL_curcop = (COP*)PL_op;
- return NORMAL;
-}
-
PP(pp_pushmark)
{
dVAR;
SV * const temp = left;
left = right; right = temp;
}
- else if (PL_op->op_private & OPpASSIGN_STATE) {
- if (SvPADSTALE(right))
- SvPADSTALE_off(right);
- else {
- (void)POPs;
- PUSHs(right);
- RETURN; /* ignore assignment */
- }
- }
if (PL_tainting && PL_tainted && !SvTAINTED(left))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
The gv becomes a(nother) reference to the constant. */
SV *const value = SvRV(cv);
- SvUPGRADE((SV *)gv, SVt_RV);
+ SvUPGRADE((SV *)gv, SVt_IV);
SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
if (!got_coderef) {
/* We've been returned a constant rather than a full subroutine,
but they expect a subroutine reference to apply. */
- ENTER;
- SvREFCNT_inc_void(SvRV(cv));
- /* newCONSTSUB takes a reference count on the passed in SV
- from us. We set the name to NULL, otherwise we get into
- 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, (SV *)newCONSTSUB(GvSTASH(right), NULL,
+ if (SvROK(cv)) {
+ ENTER;
+ SvREFCNT_inc_void(SvRV(cv));
+ /* newCONSTSUB takes a reference count on the passed in SV
+ from us. We set the name to NULL, otherwise we get into
+ 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, (SV *)newCONSTSUB(GvSTASH(right), NULL,
SvRV(cv)));
- SvREFCNT_dec(cv);
- LEAVE;
- }
+ SvREFCNT_dec(cv);
+ LEAVE;
+ } else {
+ /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
+ is that
+ First: ops for \&{"BONK"}; return us the constant in the
+ symbol table
+ Second: ops for *{"BONK"} cause that symbol table entry
+ (and our reference to it) to be upgraded from RV
+ to typeblob)
+ Thirdly: We get here. cv is actually PVGV now, and its
+ GvCV() is actually the subroutine we're looking for
- if (strEQ(GvNAME(right),"isa")) {
- GvCVGEN(right) = 0;
- ++PL_sub_generation; /* I don't get this at all --blblack */
+ So change the reference so that it points to the subroutine
+ of that typeglob, as that's what they were after all along.
+ */
+ GV *const upgraded = (GV *) cv;
+ CV *const source = GvCV(upgraded);
+
+ assert(source);
+ assert(CvFLAGS(source) & CVf_CONST);
+
+ SvREFCNT_inc_void(source);
+ SvREFCNT_dec(upgraded);
+ SvRV_set(left, (SV *)source);
+ }
}
+
}
SvSetMagicSV(right, left);
SETs(right);
/* mg_get(right) may happen here ... */
rpv = SvPV_const(right, rlen);
rbyte = !DO_UTF8(right);
- right = sv_2mortal(newSVpvn(rpv, rlen));
+ right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
rcopied = TRUE;
}
sv_utf8_upgrade_nomg(TARG);
else {
if (!rcopied)
- right = sv_2mortal(newSVpvn(rpv, rlen));
+ right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
sv_utf8_upgrade_nomg(right);
rpv = SvPV_const(right, rlen);
}
dVAR;
tryAMAGICunTARGET(iter, 0);
PL_last_in_gv = (GV*)(*PL_stack_sp--);
- if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
- if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
+ if (!isGV_with_GP(PL_last_in_gv)) {
+ if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
else {
dSP;
PP(pp_preinc)
{
dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
--SP;
RETURNOP(cLOGOP->op_other);
}
- } else if (op_type == OP_DEFINED) {
+ }
+ else {
+ /* OP_DEFINED */
sv = POPs;
if (!sv || !SvANY(sv))
RETPUSHNO;
- } else
- DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
+ }
defined = FALSE;
switch (SvTYPE(sv)) {
PP(pp_add)
{
- dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
- useleft = USE_LEFT(TOPm1s);
+ dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ tryAMAGICbin(add,opASSIGN);
+ svl = sv_2num(TOPm1s);
+ svr = sv_2num(TOPs);
+ useleft = USE_LEFT(svl);
#ifdef PERL_PRESERVE_IVUV
/* We must see if we can perform the addition with integers if possible,
as the integer code detects overflow while the NV code doesn't.
unsigned code below is actually shorter than the old code. :-)
*/
- SvIV_please(TOPs);
- if (SvIOK(TOPs)) {
+ SvIV_please(svr);
+ if (SvIOK(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(TOPm1s);
- if (SvIOK(TOPm1s)) {
- if ((auvok = SvUOK(TOPm1s)))
- auv = SvUVX(TOPm1s);
+ SvIV_please(svl);
+ if (SvIOK(svl)) {
+ if ((auvok = SvUOK(svl)))
+ auv = SvUVX(svl);
else {
- register const IV aiv = SvIVX(TOPm1s);
+ register const IV aiv = SvIVX(svl);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
bool result_good = 0;
UV result;
register UV buv;
- bool buvok = SvUOK(TOPs);
+ bool buvok = SvUOK(svr);
if (buvok)
- buv = SvUVX(TOPs);
+ buv = SvUVX(svr);
else {
- register const IV biv = SvIVX(TOPs);
+ register const IV biv = SvIVX(svr);
if (biv >= 0) {
buv = biv;
buvok = 1;
}
#endif
{
- dPOPnv;
+ NV value = SvNV(svr);
+ (void)POPs;
if (!useleft) {
/* left operand is undef, treat as zero. + 0.0 is identity. */
SETn(value);
RETURN;
}
- SETn( value + TOPn );
+ SETn( value + SvNV(svl) );
RETURN;
}
}
*MARK = SvTIED_obj((SV*)io, mg);
PUTBACK;
ENTER;
+ if( PL_op->op_type == OP_SAY ) {
+ /* local $\ = "\n" */
+ SAVEGENERICSV(PL_ors_sv);
+ PL_ors_sv = newSVpvs("\n");
+ }
call_method("PRINT", G_SCALAR);
LEAVE;
SPAGAIN;
{
dVAR; dSP; dTOPss;
const I32 gimme = GIMME_V;
- static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
- static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
static const char an_array[] = "an ARRAY";
static const char a_hash[] = "a HASH";
const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_
- is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
else {
GV *gv;
- if (SvTYPE(sv) != SVt_PVGV) {
+ if (!isGV_with_GP(sv)) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_
- is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
}
}
RETURN;
+
+ croak_cant_return:
+ Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
+ is_pp_rv2av ? "array" : "hash");
+ RETURN;
}
STATIC void
S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
{
dVAR;
+
+ PERL_ARGS_ASSERT_DO_ODDBALL;
+
if (*relem) {
SV *tmpstr;
const HE *didstore;
int duplicates = 0;
SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
- if (PL_op->op_private & OPpASSIGN_STATE) {
- if (SvPADSTALE(*firstlelem))
- SvPADSTALE_off(*firstlelem);
- else
- RETURN; /* ignore assignment */
- }
-
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
gimme = GIMME_V;
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
- if (SvSMAGICAL(sv))
+ if (SvSMAGICAL(sv)) {
+ /* More magic can happen in the mg_set callback, so we
+ * backup the delaymagic for now. */
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
mg_set(sv);
+ PL_delaymagic = dmbak;
+ }
if (!didstore)
sv_2mortal(sv);
}
TAINT_NOT;
}
+ if (PL_delaymagic & DM_ARRAY)
+ SvSETMAGIC((SV*)ary);
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
duplicates += 2;
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
- if (SvSMAGICAL(tmpstr))
+ if (SvSMAGICAL(tmpstr)) {
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
mg_set(tmpstr);
+ PL_delaymagic = dmbak;
+ }
if (!didstore)
sv_2mortal(tmpstr);
}
}
else
sv_setsv(sv, &PL_sv_undef);
- SvSETMAGIC(sv);
+
+ if (SvSMAGICAL(sv)) {
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
+ mg_set(sv);
+ PL_delaymagic = dmbak;
+ }
break;
}
}
while (relem <= SP)
*relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
}
+
RETURN;
}
dVAR; dSP;
register PMOP * const pm = cPMOP;
REGEXP * rx = PM_GETRE(pm);
- SV * const pkg = CALLREG_QRPKG(rx);
+ SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
SV * const rv = sv_newmortal();
- SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
- if (rx->extflags & RXf_TAINTED)
+
+ SvUPGRADE(rv, SVt_IV);
+ /* This RV is about to own a reference to the regexp. (In addition to the
+ reference already owned by the PMOP. */
+ ReREFCNT_inc(rx);
+ SvRV_set(rv, (SV*) rx);
+ SvROK_on(rv);
+
+ if (pkg) {
+ HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
+ (void)sv_bless(rv, stash);
+ }
+
+ if (RX_EXTFLAGS(rx) & RXf_TAINTED)
SvTAINTED_on(rv);
- sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
XPUSHs(rv);
RETURN;
}
register const char *s;
const char *strend;
I32 global;
- I32 r_flags = REXEC_CHECKED;
+ U8 r_flags = REXEC_CHECKED;
const char *truebase; /* Start of string */
register REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
if (!s)
DIE(aTHX_ "panic: pp_match");
strend = s + len;
- rxtainted = ((rx->extflags & RXf_TAINTED) ||
+ rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
/* empty pattern special-cased to use last successful pattern if possible */
- if (!rx->prelen && PL_curpm) {
+ if (!RX_PRELEN(rx) && PL_curpm) {
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- if (rx->minlen > (I32)len)
+ if (RX_MINLEN(rx) > (I32)len)
goto failure;
truebase = t = s;
/* XXXX What part of this is needed with true \G-support? */
if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
- rx->offs[0].start = -1;
+ RX_OFFS(rx)[0].start = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
- if (!(rx->extflags & RXf_GPOS_SEEN))
- rx->offs[0].end = rx->offs[0].start = mg->mg_len;
- else if (rx->extflags & RXf_ANCH_GPOS) {
+ if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
+ RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
+ else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
r_flags |= REXEC_IGNOREPOS;
- rx->offs[0].end = rx->offs[0].start = mg->mg_len;
- } else if (rx->extflags & RXf_GPOS_FLOAT)
+ RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
+ } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
gpos = mg->mg_len;
else
- rx->offs[0].end = rx->offs[0].start = mg->mg_len;
- minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
+ RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
+ minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
update_minmatch = 0;
}
}
}
- /* remove comment to get faster /g but possibly unsafe $1 vars after a
- match. Test for the unsafe vars will fail as well*/
- if (( /* !global && */ rx->nparens)
+ /* XXX: comment out !global get safe $1 vars after a
+ match, BUT be aware that this leads to dramatic slowdowns on
+ /g matches against large strings. So far a solution to this problem
+ appears to be quite tricky.
+ Test for the unsafe vars are TODO for now. */
+ if (( !global && RX_NPARENS(rx))
|| SvTEMP(TARG) || PL_sawampersand ||
- (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
+ (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
play_it_again:
- if (global && rx->offs[0].start != -1) {
- t = s = rx->offs[0].end + truebase - rx->gofs;
- if ((s + rx->minlen) > strend || s < truebase)
+ 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)
goto nope;
if (update_minmatch++)
minmatch = had_zerolen;
}
- if (rx->extflags & RXf_USE_INTUIT &&
- DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
+ if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
+ DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
/* FIXME - can PL_bostr be made const char *? */
PL_bostr = (char *)truebase;
s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
if (!s)
goto nope;
- if ( (rx->extflags & RXf_CHECK_ALL)
+ if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
- && !(rx->extflags & RXf_PMf_KEEPCOPY)
- && ((rx->extflags & RXf_NOSCAN)
- || !((rx->extflags & RXf_INTUIT_TAIL)
+ && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
+ && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
+ || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM)))
&& !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
goto yup;
}
- if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
+ if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
+ minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
{
PL_curpm = pm;
if (dynpm->op_pmflags & PMf_ONCE) {
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
if (gimme == G_ARRAY) {
- const I32 nparens = rx->nparens;
+ const I32 nparens = RX_NPARENS(rx);
I32 i = (global && !nparens) ? 1 : 0;
SPAGAIN; /* EVAL blocks could move the stack. */
EXTEND_MORTAL(nparens + i);
for (i = !i; i <= nparens; i++) {
PUSHs(sv_newmortal());
- if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
- const I32 len = rx->offs[i].end - rx->offs[i].start;
- s = rx->offs[i].start + truebase;
- if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
+ if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
+ const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
+ s = RX_OFFS(rx)[i].start + truebase;
+ if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
len < 0 || len > strend - s)
DIE(aTHX_ "panic: pp_match start/end pointers");
sv_setpvn(*SP, s, len);
mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
&PL_vtbl_mglob, NULL, 0);
}
- if (rx->offs[0].start != -1) {
- mg->mg_len = rx->offs[0].end;
- if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
+ if (RX_OFFS(rx)[0].start != -1) {
+ mg->mg_len = RX_OFFS(rx)[0].end;
+ if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
mg->mg_flags |= MGf_MINMATCH;
else
mg->mg_flags &= ~MGf_MINMATCH;
}
}
- had_zerolen = (rx->offs[0].start != -1
- && (rx->offs[0].start + rx->gofs
- == (UV)rx->offs[0].end));
+ had_zerolen = (RX_OFFS(rx)[0].start != -1
+ && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
+ == (UV)RX_OFFS(rx)[0].end));
PUTBACK; /* EVAL blocks may use stack */
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
goto play_it_again;
mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
&PL_vtbl_mglob, NULL, 0);
}
- if (rx->offs[0].start != -1) {
- mg->mg_len = rx->offs[0].end;
- if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
+ if (RX_OFFS(rx)[0].start != -1) {
+ mg->mg_len = RX_OFFS(rx)[0].end;
+ if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
mg->mg_flags |= MGf_MINMATCH;
else
mg->mg_flags &= ~MGf_MINMATCH;
#endif
}
if (RX_MATCH_COPIED(rx))
- Safefree(rx->subbeg);
+ Safefree(RX_SUBBEG(rx));
RX_MATCH_COPIED_off(rx);
- rx->subbeg = NULL;
+ RX_SUBBEG(rx) = NULL;
if (global) {
/* FIXME - should rx->subbeg be const char *? */
- rx->subbeg = (char *) truebase;
- rx->offs[0].start = s - truebase;
+ RX_SUBBEG(rx) = (char *) truebase;
+ RX_OFFS(rx)[0].start = s - truebase;
if (RX_MATCH_UTF8(rx)) {
- char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
- rx->offs[0].end = t - truebase;
+ char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
+ RX_OFFS(rx)[0].end = t - truebase;
}
else {
- rx->offs[0].end = s - truebase + rx->minlenret;
+ RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
}
- rx->sublen = strend - truebase;
+ RX_SUBLEN(rx) = strend - truebase;
goto gotcha;
}
- if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
+ if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
I32 off;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
(int) SvTYPE(TARG), (void*)truebase, (void*)t,
(int)(t-truebase));
}
- rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
- rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
- assert (SvPOKp(rx->saved_copy));
+ RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
+ RX_SUBBEG(rx)
+ = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
+ assert (SvPOKp(RX_SAVED_COPY(rx)));
} else
#endif
{
- rx->subbeg = savepvn(t, strend - t);
+ RX_SUBBEG(rx) = savepvn(t, strend - t);
#ifdef PERL_OLD_COPY_ON_WRITE
- rx->saved_copy = NULL;
+ RX_SAVED_COPY(rx) = NULL;
#endif
}
- rx->sublen = strend - t;
+ RX_SUBLEN(rx) = strend - t;
RX_MATCH_COPIED_on(rx);
- off = rx->offs[0].start = s - t;
- rx->offs[0].end = off + rx->minlenret;
+ off = RX_OFFS(rx)[0].start = s - t;
+ RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
}
else { /* startp/endp are used by @- @+. */
- rx->offs[0].start = s - truebase;
- rx->offs[0].end = s - truebase + rx->minlenret;
+ RX_OFFS(rx)[0].start = s - truebase;
+ RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
}
- /* including rx->nparens in the below code seems highly suspicious.
+ /* including RX_NPARENS(rx) in the below code seems highly suspicious.
-dmq */
- rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
+ RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
LEAVE_SCOPE(oldsave);
RETPUSHYES;
dVAR; dSP;
register PERL_CONTEXT *cx;
SV *sv, *oldsv;
- AV* av;
SV **itersvp;
+ AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
+ bool av_is_stack = FALSE;
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
- if (CxTYPE(cx) != CXt_LOOP)
+ if (!CxTYPE_is_LOOP(cx))
DIE(aTHX_ "panic: pp_iter");
itersvp = CxITERVAR(cx);
- av = cx->blk_loop.iterary;
- if (SvTYPE(av) != SVt_PVAV) {
- /* iterate ($min .. $max) */
- if (cx->blk_loop.iterlval) {
+ if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
/* string increment */
- register SV* cur = cx->blk_loop.iterlval;
+ SV* cur = cx->blk_loop.state_u.lazysv.cur;
+ SV *end = cx->blk_loop.state_u.lazysv.end;
+ /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
+ It has SvPVX of "" and SvCUR of 0, which is what we want. */
STRLEN maxlen = 0;
- const char *max =
- SvOK((SV*)av) ?
- SvPV_const((SV*)av, maxlen) : (const char *)"";
+ const char *max = SvPV_const(end, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
RETPUSHYES;
}
RETPUSHNO;
- }
+ }
+ else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
/* integer increment */
- if (cx->blk_loop.iterix > cx->blk_loop.itermax)
+ if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
RETPUSHNO;
/* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setiv(*itersvp, cx->blk_loop.iterix++);
+ 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.iterix++);
+ *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++;
+ }
+
RETPUSHYES;
}
/* iterate array */
+ assert(CxTYPE(cx) == CXt_LOOP_FOR);
+ av = cx->blk_loop.state_u.ary.ary;
+ if (!av) {
+ av_is_stack = TRUE;
+ av = PL_curstack;
+ }
if (PL_op->op_private & OPpITER_REVERSED) {
- /* In reverse, use itermax as the min :-) */
- if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
+ if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
+ ? cx->blk_loop.resetsp + 1 : 0))
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
+ SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
sv = svp ? *svp : NULL;
}
else {
- sv = AvARRAY(av)[--cx->blk_loop.iterix];
+ sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
}
}
else {
- if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
+ if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
AvFILL(av)))
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
sv = svp ? *svp : NULL;
}
else {
- sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
}
}
Perl_croak(aTHX_ "Use of freed value in iteration");
}
- if (sv)
+ if (sv) {
SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
else
sv = &PL_sv_undef;
- if (av != PL_curstack && sv == &PL_sv_undef) {
- SV *lv = cx->blk_loop.iterlval;
- if (lv && SvREFCNT(lv) > 1) {
- SvREFCNT_dec(lv);
- lv = NULL;
- }
- if (lv)
- SvREFCNT_dec(LvTARG(lv));
- else {
- lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
- LvTYPE(lv) = 'y';
- sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
- }
+ if (!av_is_stack && sv == &PL_sv_undef) {
+ SV *lv = newSV_type(SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
LvTARG(lv) = SvREFCNT_inc_simple(av);
- LvTARGOFF(lv) = cx->blk_loop.iterix;
+ LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
LvTARGLEN(lv) = (STRLEN)UV_MAX;
- sv = (SV*)lv;
+ sv = lv;
}
oldsv = *itersvp;
- *itersvp = SvREFCNT_inc_simple_NN(sv);
+ *itersvp = sv;
SvREFCNT_dec(oldsv);
RETPUSHYES;
I32 maxiters;
register I32 i;
bool once;
- bool rxtainted;
+ U8 rxtainted;
char *orig;
- I32 r_flags;
+ U8 r_flags;
register REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
+ I32 matched;
#ifdef PERL_OLD_COPY_ON_WRITE
bool is_cow;
#endif
s = SvPV_mutable(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
- rxtainted = ((rx->extflags & RXf_TAINTED) ||
+ rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
if (PL_tainted)
rxtainted |= 2;
position, once with zero-length,
second time with non-zero. */
- if (!rx->prelen && PL_curpm) {
+ if (!RX_PRELEN(rx) && PL_curpm) {
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
- || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
+ r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
orig = m = s;
- if (rx->extflags & RXf_USE_INTUIT) {
+ if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
PL_bostr = orig;
s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
if (!s)
goto nope;
/* How to do it in subst? */
-/* if ( (rx->extflags & RXf_CHECK_ALL)
+/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
- && !(rx->extflags & RXf_KEEPCOPY)
- && ((rx->extflags & RXf_NOSCAN)
- || !((rx->extflags & RXf_INTUIT_TAIL)
+ && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
+ && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
+ || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM))))
goto yup;
*/
/* only replace once? */
once = !(rpm->op_pmflags & PMf_GLOBAL);
-
+ matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
+ r_flags | REXEC_CHECKED);
/* known replacement string? */
if (dstr) {
/* replacement needing upgrading? */
#ifdef PERL_OLD_COPY_ON_WRITE
&& !is_cow
#endif
- && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
- && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
+ && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
+ && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
&& (!doutf8 || SvUTF8(TARG))) {
- if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED))
+ if (!matched)
{
SPAGAIN;
PUSHs(&PL_sv_no);
SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
rxtainted |= RX_MATCH_TAINTED(rx);
- m = orig + rx->offs[0].start;
- d = orig + rx->offs[0].end;
+ m = orig + RX_OFFS(rx)[0].start;
+ d = orig + RX_OFFS(rx)[0].end;
s = orig;
if (m - s > strend - d) { /* faster to shorten from end */
if (clen) {
else if ((i = m - s)) { /* faster from front */
d -= clen;
m = d;
+ Move(s, d - i, i, char);
sv_chop(TARG, d-i);
- s += i;
- while (i--)
- *--d = *--s;
if (clen)
Copy(c, m, clen, char);
}
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
rxtainted |= RX_MATCH_TAINTED(rx);
- m = rx->offs[0].start + orig;
+ m = RX_OFFS(rx)[0].start + orig;
if ((i = m - s)) {
if (s != d)
Move(s, d, i, char);
Copy(c, d, clen, char);
d += clen;
}
- s = rx->offs[0].end + orig;
+ s = RX_OFFS(rx)[0].end + orig;
} while (CALLREGEXEC(rx, s, strend, orig, s == m,
TARG, NULL,
/* don't match same null twice */
}
TAINT_IF(rxtainted & 1);
SPAGAIN;
- PUSHs(sv_2mortal(newSViv((I32)iters)));
+ mPUSHi((I32)iters);
}
(void)SvPOK_only_UTF8(TARG);
TAINT_IF(rxtainted);
RETURN;
}
- if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED))
+ if (matched)
{
if (force_on_match) {
force_on_match = 0;
have_a_cow:
#endif
rxtainted |= RX_MATCH_TAINTED(rx);
- dstr = newSVpvn(m, s-m);
+ dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
SAVEFREESV(dstr);
- if (DO_UTF8(TARG))
- SvUTF8_on(dstr);
PL_curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
rxtainted |= RX_MATCH_TAINTED(rx);
- if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
+ if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
- orig = rx->subbeg;
+ orig = RX_SUBBEG(rx);
s = orig + (m - s);
strend = s + (strend - m);
}
- m = rx->offs[0].start + orig;
+ m = RX_OFFS(rx)[0].start + orig;
if (doutf8 && !SvUTF8(dstr))
sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
else
sv_catpvn(dstr, s, m-s);
- s = rx->offs[0].end + orig;
+ s = RX_OFFS(rx)[0].end + orig;
if (clen)
sv_catpvn(dstr, c, clen);
if (once)
TAINT_IF(rxtainted & 1);
SPAGAIN;
- PUSHs(sv_2mortal(newSViv((I32)iters)));
+ mPUSHi((I32)iters);
(void)SvPOK_only(TARG);
if (doutf8)
TAINT_NOT;
- if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
+ if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
/* We are an argument to a function or grep().
* This kind of lvalueness was legal before lvalue
* subroutines too, so be backward compatible:
}
}
}
- else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
+ else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
/* Here we go for robustness, not for speed, so we change all
* the refcounts so the caller gets a live guy. Cannot set
* TEMP, so sv_2mortal is out of question. */
switch (SvTYPE(sv)) {
/* This is overwhelming the most common case: */
case SVt_PVGV:
+ if (!isGV_with_GP(sv))
+ DIE(aTHX_ "Not a CODE reference");
if (!(cv = GvCVu((GV*)sv))) {
HV *stash;
cv = sv_2cv(sv, &stash, &gv, 0);
gimme = GIMME_V;
if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
- if (CvASSERTION(cv) && PL_DBassertion)
- sv_setiv(PL_DBassertion, 1);
-
Perl_get_db_sub(aTHX_ &sv, cv);
if (CvISXSUB(cv))
PL_curcopdb = PL_curcop;
* stuff so that __WARN__ handlers can safely dounwind()
* if they want to
*/
- if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
+ if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
&& !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
sub_crush_depth(cv);
-#if 0
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
-#endif
RETURNOP(CvSTART(cv));
}
else {
void
Perl_sub_crush_depth(pTHX_ CV *cv)
{
+ PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
+
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
void
Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
{
+ PERL_ARGS_ASSERT_VIVIFY_REF;
+
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
Perl_croak(aTHX_ PL_no_modify);
- if (SvTYPE(sv) < SVt_RV)
- sv_upgrade(sv, SVt_RV);
- else if (SvTYPE(sv) >= SVt_PV) {
- SvPV_free(sv);
- SvLEN_set(sv, 0);
- SvCUR_set(sv, 0);
- }
+ prepare_SV_for_RV(sv);
switch (to_what) {
case OPpDEREF_SV:
SvRV_set(sv, newSV(0));
const char * const name = SvPV_const(meth, namelen);
SV * const sv = *(PL_stack_base + TOPMARK + 1);
+ PERL_ARGS_ASSERT_METHOD_COMMON;
+
if (!sv)
Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
packsv = sv;
else {
SV* const ref = newSViv(PTR2IV(stash));
- hv_store(PL_stashcache, packname, packlen, ref, 0);
+ (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
}
goto fetch;
}
/* if we got here, ob should be a reference or a glob */
if (!ob || !(SvOBJECT(ob)
- || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
+ || (SvTYPE(ob) == SVt_PVGV
+ && isGV_with_GP(ob)
+ && (ob = (SV*)GvIO((GV*)ob))
&& SvOBJECT(ob))))
{
Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
gv = (GV*)HeVAL(he);
if (isGV(gv) && GvCV(gv) &&
(!GvCVGEN(gv) || GvCVGEN(gv)
- == (PL_sub_generation + HvMROMETA(stash)->sub_generation)))
+ == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
return (SV*)GvCV(gv);
}
}
- gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
-
- if (!gv) {
- /* This code tries to figure out just what went wrong with
- gv_fetchmethod. It therefore needs to duplicate a lot of
- the internals of that function. We can't move it inside
- Perl_gv_fetchmethod_autoload(), however, since that would
- cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
- don't want that.
- */
- const char* leaf = name;
- const char* sep = NULL;
- const char* p;
-
- for (p = name; *p; p++) {
- if (*p == '\'')
- sep = p, leaf = p + 1;
- else if (*p == ':' && *(p + 1) == ':')
- sep = p, leaf = p + 2;
- }
- if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
- /* the method name is unqualified or starts with SUPER:: */
- bool need_strlen = 1;
- if (sep) {
- packname = CopSTASHPV(PL_curcop);
- }
- else if (stash) {
- HEK * const packhek = HvNAME_HEK(stash);
- if (packhek) {
- packname = HEK_KEY(packhek);
- packlen = HEK_LEN(packhek);
- need_strlen = 0;
- } else {
- goto croak;
- }
- }
+ gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
+ GV_AUTOLOAD | GV_CROAK);
- if (!packname) {
- croak:
- Perl_croak(aTHX_
- "Can't use anonymous symbol table for method lookup");
- }
- else if (need_strlen)
- packlen = strlen(packname);
+ assert(gv);
- }
- else {
- /* the method name is qualified */
- packname = name;
- packlen = sep - name;
- }
-
- /* we're relying on gv_fetchmethod not autovivifying the stash */
- if (gv_stashpvn(packname, packlen, 0)) {
- Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\"",
- leaf, (int)packlen, packname);
- }
- else {
- Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\""
- " (perhaps you forgot to load \"%.*s\"?)",
- leaf, (int)packlen, packname, (int)packlen, packname);
- }
- }
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
}