X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=1535e4cd8f7c069b73e3a45016ee386cf1e8ded1;hb=c16639b530c8551bfbd92ceea654ab91dfea918a;hp=5dd8104849102cd773925a477b08793529772555;hpb=17ab79462074d95168fb4cd137197d4e6a0696b2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index 5dd8104..1535e4c 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -39,7 +39,14 @@ PP(pp_const)
 {
     dVAR;
     dSP;
-    XPUSHs(cSVOP_sv);
+    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);
     RETURN;
 }
 
@@ -120,12 +127,6 @@ PP(pp_sassign)
 	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) {
@@ -179,11 +180,6 @@ PP(pp_sassign)
 	    SvREFCNT_dec(cv);
 	    LEAVE;
 	}
-
-	if (strEQ(GvNAME(right),"isa")) {
-	    GvCVGEN(right) = 0;
-	    ++PL_sub_generation;
-	}
     }
     SvSetMagicSV(right, left);
     SETs(right);
@@ -430,12 +426,13 @@ PP(pp_defined)
 		--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)) {
@@ -788,7 +785,7 @@ PP(pp_rv2av)
     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;
-    const U32 type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
+    const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 
     if (SvROK(sv)) {
       wasref:
@@ -836,35 +833,10 @@ PP(pp_rv2av)
 		    if (SvROK(sv))
 			goto wasref;
 		}
-		if (!SvOK(sv)) {
-		    if (PL_op->op_flags & OPf_REF ||
-		      PL_op->op_private & HINT_STRICT_REFS)
-			DIE(aTHX_ PL_no_usym, is_pp_rv2av ? an_array : a_hash);
-		    if (ckWARN(WARN_UNINITIALIZED))
-			report_uninit(sv);
-		    if (gimme == G_ARRAY) {
-			SP--;
-			RETURN;
-		    }
-		    RETSETUNDEF;
-		}
-		if ((PL_op->op_flags & OPf_SPECIAL) &&
-		    !(PL_op->op_flags & OPf_MOD))
-		{
-		    gv = (GV*)gv_fetchsv(sv, 0, type);
-		    if (!gv
-			&& (!is_gv_magical_sv(sv,0)
-			    || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, type))))
-		    {
-			RETSETUNDEF;
-		    }
-		}
-		else {
-		    if (PL_op->op_private & HINT_STRICT_REFS)
-			DIE(aTHX_ PL_no_symref_sv, sv,
-			    is_pp_rv2av ? an_array : a_hash);
-		    gv = (GV*)gv_fetchsv(sv, GV_ADD, type);
-		}
+		gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
+				     type, &sp);
+		if (!gv)
+		    RETURN;
 	    }
 	    else {
 		gv = (GV*)sv;
@@ -925,6 +897,7 @@ PP(pp_rv2av)
     else if (gimme == G_SCALAR) {
 	dTARGET;
     TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
+	SPAGAIN;
 	SETTARG;
     }
     }
@@ -986,7 +959,6 @@ PP(pp_aassign)
     int duplicates = 0;
     SV **firsthashrelem = NULL;	/* "= 0" keeps gcc 2.95 quiet  */
 
-
     PL_delaymagic = DM_DELAY;		/* catch simultaneous items */
     gimme = GIMME_V;
 
@@ -1003,12 +975,6 @@ PP(pp_aassign)
 	    }
 	}
     }
-    if (PL_op->op_private & OPpASSIGN_STATE) {
-	if (SvPADSTALE(*firstlelem))
-	    SvPADSTALE_off(*firstlelem);
-	else
-	    RETURN; /* ignore assignment */
-    }
 
     relem = firstrelem;
     lelem = firstlelem;
@@ -1185,6 +1151,15 @@ PP(pp_aassign)
 	while (relem <= SP)
 	    *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
     }
+
+    /* This is done at the bottom and in this order because
+       mro_isa_changed_in() can throw exceptions */
+    if(PL_delayedisa) {
+        HV* stash = PL_delayedisa;
+        PL_delayedisa = NULL;
+        mro_isa_changed_in(stash);
+    }
+
     RETURN;
 }
 
@@ -1192,12 +1167,15 @@ PP(pp_qr)
 {
     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);
-    RETURNX(PUSHs(rv));
+    sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
+    XPUSHs(rv);
+    RETURN;
 }
 
 PP(pp_match)
@@ -1235,20 +1213,28 @@ PP(pp_match)
     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;
@@ -1262,36 +1248,39 @@ PP(pp_match)
 
     /* 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 drammatic 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++)
@@ -1307,7 +1296,7 @@ play_it_again:
 	    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)))
@@ -1317,8 +1306,13 @@ play_it_again:
     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(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
@@ -1338,10 +1332,10 @@ play_it_again:
 	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);
@@ -1362,16 +1356,17 @@ 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;
 		}
 	    }
-	    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;
@@ -1396,9 +1391,9 @@ 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;
@@ -1413,8 +1408,13 @@ yup:					/* Confirmed by INTUIT */
 	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);
@@ -1422,18 +1422,18 @@ yup:					/* Confirmed by INTUIT */
     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) {
@@ -1457,12 +1457,12 @@ yup:					/* Confirmed by INTUIT */
 	}
 	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 */
@@ -1968,8 +1968,7 @@ PP(pp_iter)
 	if (lv)
 	    SvREFCNT_dec(LvTARG(lv));
 	else {
-	    lv = cx->blk_loop.iterlval = newSV(0);
-	    sv_upgrade(lv, SVt_PVLV);
+	    lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
 	    LvTYPE(lv) = 'y';
 	    sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
 	}
@@ -2048,7 +2047,7 @@ PP(pp_subst)
     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;
@@ -2071,7 +2070,7 @@ PP(pp_subst)
 	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;
@@ -2086,7 +2085,7 @@ PP(pp_subst)
 	/* 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))))
@@ -2152,8 +2151,8 @@ PP(pp_subst)
 	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) {
@@ -2195,7 +2194,7 @@ PP(pp_subst)
 		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);
@@ -2205,7 +2204,7 @@ PP(pp_subst)
 		    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 */
@@ -2254,7 +2253,7 @@ PP(pp_subst)
 	    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 {
@@ -2268,12 +2267,12 @@ PP(pp_subst)
 		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)
@@ -2714,9 +2713,6 @@ try_autoload:
 
     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;
@@ -3018,7 +3014,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 				    : "on an undefined value");
 	    }
 	    /* assume it's a package name */
-	    stash = gv_stashpvn(packname, packlen, FALSE);
+	    stash = gv_stashpvn(packname, packlen, 0);
 	    if (!stash)
 		packsv = sv;
             else {
@@ -3037,6 +3033,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 		     && SvOBJECT(ob))))
     {
 	Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
+		   (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
 		   name);
     }
 
@@ -3052,7 +3049,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	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);
 	}
     }
@@ -3110,7 +3108,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	}
 	
 	/* we're relying on gv_fetchmethod not autovivifying the stash */
-	if (gv_stashpvn(packname, packlen, FALSE)) {
+	if (gv_stashpvn(packname, packlen, 0)) {
 	    Perl_croak(aTHX_
 		       "Can't locate object method \"%s\" via package \"%.*s\"",
 		       leaf, (int)packlen, packname);