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) {
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
+
+ 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);
- if (strEQ(GvNAME(right),"isa")) {
- GvCVGEN(right) = 0;
- ++PL_sub_generation;
+ assert(source);
+ assert(CvFLAGS(source) & CVf_CONST);
+
+ SvREFCNT_inc_void(source);
+ SvREFCNT_dec(upgraded);
+ SvRV_set(left, (SV *)source);
+ }
}
+
}
SvSetMagicSV(right, left);
SETs(right);
--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;
}
}
int duplicates = 0;
SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
-
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
gimme = GIMME_V;
}
}
}
- if (PL_op->op_private & OPpASSIGN_STATE) {
- if (SvPADSTALE(*firstlelem))
- SvPADSTALE_off(*firstlelem);
- else
- RETURN; /* ignore assignment */
- }
relem = firstrelem;
lelem = firstlelem;
}
TAINT_NOT;
}
+ if (PL_delaymagic & DM_ARRAY)
+ SvSETMAGIC((SV*)ary);
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
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_PACKAGE(rx);
SV * const rv = sv_newmortal();
- SV * const sv = newSVrv(rv, "Regexp");
- if (pm->op_pmdynflags & PMdf_TAINTED)
+ SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
+ if (rx->extflags & RXf_TAINTED)
SvTAINTED_on(rv);
- sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
+ sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
XPUSHs(rv);
RETURN;
}
if (!s)
DIE(aTHX_ "panic: pp_match");
strend = s + len;
- rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
+ rxtainted = ((rx->extflags & RXf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
/* PMdf_USED is set after a ?? matches once */
- if (pm->op_pmdynflags & PMdf_USED) {
+ if (
+#ifdef USE_ITHREADS
+ SvREADONLY(PL_regex_pad[pm->op_pmoffset])
+#else
+ pm->op_pmflags & PMf_USED
+#endif
+ ) {
failure:
if (gimme == G_ARRAY)
RETURN;
RETPUSHNO;
}
+
+
/* empty pattern special-cased to use last successful pattern if possible */
if (!rx->prelen && PL_curpm) {
pm = PL_curpm;
/* XXXX What part of this is needed with true \G-support? */
if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
- rx->startp[0] = -1;
+ rx->offs[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->endp[0] = rx->startp[0] = mg->mg_len;
+ rx->offs[0].end = rx->offs[0].start = mg->mg_len;
else if (rx->extflags & RXf_ANCH_GPOS) {
r_flags |= REXEC_IGNOREPOS;
- rx->endp[0] = rx->startp[0] = mg->mg_len;
+ rx->offs[0].end = rx->offs[0].start = mg->mg_len;
} else if (rx->extflags & RXf_GPOS_FLOAT)
gpos = mg->mg_len;
else
- rx->endp[0] = rx->startp[0] = mg->mg_len;
+ rx->offs[0].end = rx->offs[0].start = mg->mg_len;
minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 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)
|| SvTEMP(TARG) || PL_sawampersand ||
- (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
+ (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
play_it_again:
- if (global && rx->startp[0] != -1) {
- t = s = rx->endp[0] + truebase - rx->gofs;
+ if (global && rx->offs[0].start != -1) {
+ t = s = rx->offs[0].end + truebase - rx->gofs;
if ((s + rx->minlen) > strend || s < truebase)
goto nope;
if (update_minmatch++)
goto nope;
if ( (rx->extflags & RXf_CHECK_ALL)
&& !PL_sawampersand
- && !(pm->op_pmflags & PMf_KEEPCOPY)
+ && !(rx->extflags & RXf_PMf_KEEPCOPY)
&& ((rx->extflags & RXf_NOSCAN)
|| !((rx->extflags & 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)
- dynpm->op_pmdynflags |= PMdf_USED;
+ if (dynpm->op_pmflags & PMf_ONCE) {
+#ifdef USE_ITHREADS
+ SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
+#else
+ dynpm->op_pmflags |= PMf_USED;
+#endif
+ }
goto gotcha;
}
else
EXTEND_MORTAL(nparens + i);
for (i = !i; i <= nparens; i++) {
PUSHs(sv_newmortal());
- if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
- const I32 len = rx->endp[i] - rx->startp[i];
- s = rx->startp[i] + truebase;
- if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
+ 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 ||
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->startp[0] != -1) {
- mg->mg_len = rx->endp[0];
- if (rx->startp[0] + rx->gofs == (UV)rx->endp[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)
mg->mg_flags |= MGf_MINMATCH;
else
mg->mg_flags &= ~MGf_MINMATCH;
}
}
- had_zerolen = (rx->startp[0] != -1
- && rx->startp[0] + rx->gofs == (UV)rx->endp[0]);
+ had_zerolen = (rx->offs[0].start != -1
+ && (rx->offs[0].start + rx->gofs
+ == (UV)rx->offs[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->startp[0] != -1) {
- mg->mg_len = rx->endp[0];
- if (rx->startp[0] + rx->gofs == (UV)rx->endp[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)
mg->mg_flags |= MGf_MINMATCH;
else
mg->mg_flags &= ~MGf_MINMATCH;
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
PL_curpm = pm;
- if (dynpm->op_pmflags & PMf_ONCE)
- dynpm->op_pmdynflags |= PMdf_USED;
+ if (dynpm->op_pmflags & PMf_ONCE) {
+#ifdef USE_ITHREADS
+ SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
+#else
+ dynpm->op_pmflags |= PMf_USED;
+#endif
+ }
if (RX_MATCH_COPIED(rx))
Safefree(rx->subbeg);
RX_MATCH_COPIED_off(rx);
if (global) {
/* FIXME - should rx->subbeg be const char *? */
rx->subbeg = (char *) truebase;
- rx->startp[0] = s - truebase;
+ rx->offs[0].start = s - truebase;
if (RX_MATCH_UTF8(rx)) {
char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
- rx->endp[0] = t - truebase;
+ rx->offs[0].end = t - truebase;
}
else {
- rx->endp[0] = s - truebase + rx->minlenret;
+ rx->offs[0].end = s - truebase + rx->minlenret;
}
rx->sublen = strend - truebase;
goto gotcha;
}
- if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) {
+ if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
I32 off;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
}
rx->sublen = strend - t;
RX_MATCH_COPIED_on(rx);
- off = rx->startp[0] = s - t;
- rx->endp[0] = off + rx->minlenret;
+ off = rx->offs[0].start = s - t;
+ rx->offs[0].end = off + rx->minlenret;
}
else { /* startp/endp are used by @- @+. */
- rx->startp[0] = s - truebase;
- rx->endp[0] = s - truebase + rx->minlenret;
+ rx->offs[0].start = s - truebase;
+ rx->offs[0].end = s - truebase + rx->minlenret;
}
/* including rx->nparens in the below code seems highly suspicious.
-dmq */
s = SvPV_mutable(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
- rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
+ rxtainted = ((rx->extflags & RXf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
if (PL_tainted)
rxtainted |= 2;
rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
- || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) )
+ || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
/* How to do it in subst? */
/* if ( (rx->extflags & RXf_CHECK_ALL)
&& !PL_sawampersand
- && !(pm->op_pmflags & PMf_KEEPCOPY)
+ && !(rx->extflags & RXf_KEEPCOPY)
&& ((rx->extflags & RXf_NOSCAN)
|| !((rx->extflags & RXf_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM))))
SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
rxtainted |= RX_MATCH_TAINTED(rx);
- m = orig + rx->startp[0];
- d = orig + rx->endp[0];
+ m = orig + rx->offs[0].start;
+ d = orig + rx->offs[0].end;
s = orig;
if (m - s > strend - d) { /* faster to shorten from end */
if (clen) {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
rxtainted |= RX_MATCH_TAINTED(rx);
- m = rx->startp[0] + orig;
+ m = rx->offs[0].start + orig;
if ((i = m - s)) {
if (s != d)
Move(s, d, i, char);
Copy(c, d, clen, char);
d += clen;
}
- s = rx->endp[0] + orig;
+ s = rx->offs[0].end + orig;
} while (CALLREGEXEC(rx, s, strend, orig, s == m,
TARG, NULL,
/* don't match same null twice */
register PERL_CONTEXT *cx;
SPAGAIN;
PUSHSUBST(cx);
- RETURNOP(cPMOP->op_pmreplroot);
+ RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
}
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
do {
s = orig + (m - s);
strend = s + (strend - m);
}
- m = rx->startp[0] + orig;
+ m = rx->offs[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->endp[0] + orig;
+ s = rx->offs[0].end + orig;
if (clen)
sv_catpvn(dstr, c, clen);
if (once)
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;
if (!SvOK(sv)) {
if (SvREADONLY(sv))
Perl_croak(aTHX_ PL_no_modify);
- if (SvTYPE(sv) < SVt_RV)
- sv_upgrade(sv, SVt_RV);
+ if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV)
+ sv_upgrade(sv, SVt_IV);
else if (SvTYPE(sv) >= SVt_PV) {
SvPV_free(sv);
SvLEN_set(sv, 0);
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;
}
&& SvOBJECT(ob))))
{
Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
+ (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
name);
}
if (he) {
gv = (GV*)HeVAL(he);
if (isGV(gv) && GvCV(gv) &&
- (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
+ (!GvCVGEN(gv) || GvCVGEN(gv)
+ == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
return (SV*)GvCV(gv);
}
}
}
if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
/* the method name is unqualified or starts with SUPER:: */
+#ifndef USE_ITHREADS
+ if (sep)
+ stash = CopSTASH(PL_curcop);
+#else
bool need_strlen = 1;
if (sep) {
packname = CopSTASHPV(PL_curcop);
}
- else if (stash) {
+ else
+#endif
+ if (stash) {
HEK * const packhek = HvNAME_HEK(stash);
if (packhek) {
packname = HEK_KEY(packhek);
packlen = HEK_LEN(packhek);
+#ifdef USE_ITHREADS
need_strlen = 0;
+#endif
} else {
goto croak;
}
Perl_croak(aTHX_
"Can't use anonymous symbol table for method lookup");
}
- else if (need_strlen)
+#ifdef USE_ITHREADS
+ if (need_strlen)
packlen = strlen(packname);
+#endif
}
else {