X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=c721680e212e831b09dcb1689a2d022cd267550b;hb=970d0ca27a2290119cbaa2df59b308a84a879664;hp=1d8ef684ce582e96efe508056c75017a0ff8bd95;hpb=c6ed36e16dcdd4c25349e4f9d5c84061095ccffb;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index 1d8ef68..c721680 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -250,8 +250,13 @@ PP(pp_aelemfast)
 {
     djSP;
     AV *av = GvAV((GV*)cSVOP->op_sv);
-    SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
-    PUSHs(svp ? *svp : &sv_undef);
+    U32 lval = op->op_flags & OPf_MOD;
+    SV** svp = av_fetch(av, op->op_private, lval);
+    SV *sv = (svp ? *svp : &sv_undef);
+    EXTEND(SP, 1);
+    if (!lval && SvGMAGICAL(sv))	/* see note in pp_helem() */
+	sv = sv_mortalcopy(sv);
+    PUSHs(sv);
     RETURN;
 }
 
@@ -539,7 +544,8 @@ PP(pp_rv2hv)
     }
     else {
 	dTARGET;
-	/* This bit is OK even when hv is really an AV */
+	if (SvTYPE(hv) == SVt_PVAV)
+	    hv = avhv_keys((AV*)hv);
 	if (HvFILL(hv))
 	    sv_setpvf(TARG, "%ld/%ld",
 		      (long)HvFILL(hv), (long)HvMAX(hv) + 1);
@@ -625,7 +631,6 @@ PP(pp_aassign)
 		hv_clear(hash);
 
 		while (relem < lastrelem) {	/* gobble up all the rest */
-		    STRLEN len;
 		    HE *didstore;
 		    if (*relem)
 			sv = *(relem++);
@@ -644,14 +649,36 @@ PP(pp_aassign)
 		    }
 		    TAINT_NOT;
 		}
-		if (relem == lastrelem && dowarn)
-		    warn("Odd number of elements in hash list");
+		if (relem == lastrelem) {
+		    if (*relem) {
+			HE *didstore;
+			if (dowarn) {
+			    if (relem == firstrelem &&
+				SvROK(*relem) &&
+				( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
+				  SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
+				warn("Reference found where even-sized list expected");
+			    else
+				warn("Odd number of elements in hash assignment");
+			}
+			tmpstr = NEWSV(29,0);
+			didstore = hv_store_ent(hash,*relem,tmpstr,0);
+			if (magic) {
+			    if (SvSMAGICAL(tmpstr))
+				mg_set(tmpstr);
+			    if (!didstore)
+				SvREFCNT_dec(tmpstr);
+			}
+			TAINT_NOT;
+		    }
+		    relem++;
+		}
 	    }
 	    break;
 	default:
 	    if (SvTHINKFIRST(sv)) {
 		if (SvREADONLY(sv) && curcop != &compiling) {
-		    if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
+		    if (!SvIMMORTAL(sv))
 			DIE(no_modify);
 		    if (relem <= lastrelem)
 			relem++;
@@ -693,12 +720,12 @@ PP(pp_aassign)
 	    if (delaymagic & DM_UID) {
 		if (uid != euid)
 		    DIE("No setreuid available");
-		(void)setuid(uid);
+		(void)PerlProc_setuid(uid);
 	    }
 #  endif /* HAS_SETREUID */
 #endif /* HAS_SETRESUID */
-	    uid = (int)getuid();
-	    euid = (int)geteuid();
+	    uid = (int)PerlProc_getuid();
+	    euid = (int)PerlProc_geteuid();
 	}
 	if (delaymagic & DM_GID) {
 #ifdef HAS_SETRESGID
@@ -722,12 +749,12 @@ PP(pp_aassign)
 	    if (delaymagic & DM_GID) {
 		if (gid != egid)
 		    DIE("No setregid available");
-		(void)setgid(gid);
+		(void)PerlProc_setgid(gid);
 	    }
 #  endif /* HAS_SETREGID */
 #endif /* HAS_SETRESGID */
-	    gid = (int)getgid();
-	    egid = (int)getegid();
+	    gid = (int)PerlProc_getgid();
+	    egid = (int)PerlProc_getegid();
 	}
 	tainting |= (uid && (euid != uid || egid != gid));
     }
@@ -753,6 +780,16 @@ PP(pp_aassign)
     RETURN;
 }
 
+PP(pp_qr)
+{
+    djSP;
+    register PMOP *pm = cPMOP;
+    SV *rv = sv_newmortal();
+    SV *sv = newSVrv(rv, "Regexp");
+    sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
+    RETURNX(PUSHs(rv));
+}
+
 PP(pp_match)
 {
     djSP; dTARG;
@@ -764,6 +801,7 @@ PP(pp_match)
     I32 safebase;
     char *truebase;
     register REGEXP *rx = pm->op_pmregexp;
+    bool rxtainted;
     I32 gimme = GIMME;
     STRLEN len;
     I32 minmatch = 0;
@@ -782,9 +820,11 @@ PP(pp_match)
     strend = s + len;
     if (!s)
 	DIE("panic: do_match");
+    rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
+		 (tainted && (pm->op_pmflags & PMf_RETAINT)));
     TAINT_NOT;
 
-    if (pm->op_pmflags & PMf_USED) {
+    if (pm->op_pmdynflags & PMdf_USED) {
       failure:
 	if (gimme == G_ARRAY)
 	    RETURN;
@@ -847,11 +887,11 @@ play_it_again:
 	    }
 	    else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
 				     (unsigned char*)strend, 
-				     rx->check_substr)))
+				     rx->check_substr, 0)))
 		goto nope;
 	    else if ((rx->reganch & ROPT_CHECK_ALL) && !sawampersand)
 		goto yup;
-	    if (s && rx->check_offset_max < t - s) {
+	    if (s && rx->check_offset_max < s - t) {
 		++BmUSEFUL(rx->check_substr);
 		s -= rx->check_offset_max;
 	    }
@@ -875,12 +915,12 @@ play_it_again:
 	    rx->float_substr = Nullsv;
 	}
     }
-    if (regexec_flags(rx, s, strend, truebase, minmatch,
+    if (CALLREGEXEC(rx, s, strend, truebase, minmatch,
 		      screamer, NULL, safebase))
     {
 	curpm = pm;
 	if (pm->op_pmflags & PMf_ONCE)
-	    pm->op_pmflags |= PMf_USED;
+	    pm->op_pmdynflags |= PMdf_USED;
 	goto gotcha;
     }
     else
@@ -888,6 +928,8 @@ play_it_again:
     /*NOTREACHED*/
 
   gotcha:
+    if (rxtainted)
+	RX_MATCH_TAINTED_on(rx);
     TAINT_IF(RX_MATCH_TAINTED(rx));
     if (gimme == G_ARRAY) {
 	I32 iters, i, len;
@@ -941,11 +983,13 @@ play_it_again:
     }
 
 yup:					/* Confirmed by check_substr */
+    if (rxtainted)
+	RX_MATCH_TAINTED_on(rx);
     TAINT_IF(RX_MATCH_TAINTED(rx));
     ++BmUSEFUL(rx->check_substr);
     curpm = pm;
     if (pm->op_pmflags & PMf_ONCE)
-	pm->op_pmflags |= PMf_USED;
+	pm->op_pmdynflags |= PMdf_USED;
     Safefree(rx->subbase);
     rx->subbase = Nullch;
     if (global) {
@@ -1019,8 +1063,11 @@ do_readline(void)
 		    IoFLAGS(io) &= ~IOf_START;
 		    IoLINES(io) = 0;
 		    if (av_len(GvAVn(last_in_gv)) < 0) {
-			SV *tmpstr = newSVpv("-", 1); /* assume stdin */
-			av_push(GvAVn(last_in_gv), tmpstr);
+			do_open(last_in_gv,"-",1,FALSE,0,0,Nullfp);
+			sv_setpvn(GvSV(last_in_gv), "-", 1);
+			SvSETMAGIC(GvSV(last_in_gv));
+			fp = IoIFP(io);
+			goto have_fp;
 		    }
 		}
 		fp = nextargv(last_in_gv);
@@ -1168,6 +1215,7 @@ do_readline(void)
 	}
 	RETURN;
     }
+  have_fp:
     if (gimme == G_SCALAR) {
 	sv = TARG;
 	if (SvROK(sv))
@@ -1282,6 +1330,7 @@ PP(pp_helem)
     HV *hv = (HV*)POPs;
     U32 lval = op->op_flags & OPf_MOD;
     U32 defer = op->op_private & OPpLVAL_DEFER;
+    SV *sv;
 
     if (SvTYPE(hv) == SVt_PVHV) {
 	he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
@@ -1318,7 +1367,16 @@ PP(pp_helem)
 	else if (op->op_private & OPpDEREF)
 	    vivify_ref(*svp, op->op_private & OPpDEREF);
     }
-    PUSHs(svp ? *svp : &sv_undef);
+    sv = (svp ? *svp : &sv_undef);
+    /* This makes C<local $tied{foo} = $tied{foo}> possible.
+     * Pushing the magical RHS on to the stack is useless, since
+     * that magic is soon destined to be misled by the local(),
+     * and thus the later pp_sassign() will fail to mg_get() the
+     * old value.  This should also cure problems with delayed
+     * mg_get()s.  GSAR 98-07-03 */
+    if (!lval && SvGMAGICAL(sv))
+	sv = sv_mortalcopy(sv);
+    PUSHs(sv);
     RETURN;
 }
 
@@ -1391,6 +1449,40 @@ PP(pp_iter)
 	DIE("panic: pp_iter");
 
     av = cx->blk_loop.iterary;
+    if (SvTYPE(av) != SVt_PVAV) {
+	/* iterate ($min .. $max) */
+	if (cx->blk_loop.iterlval) {
+	    /* string increment */
+	    register SV* cur = cx->blk_loop.iterlval;
+	    STRLEN maxlen;
+	    char *max = SvPV((SV*)av, maxlen);
+	    if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
+	        /* we need a fresh SV every time so that loop body sees a
+		 * completely new SV for closures/references to work as they
+		 * used to */
+		SvREFCNT_dec(*cx->blk_loop.itervar);
+		*cx->blk_loop.itervar = newSVsv(cur);
+		if (strEQ(SvPVX(cur), max))
+		    sv_setiv(cur, 0); /* terminate next time */
+		else
+		    sv_inc(cur);
+		RETPUSHYES;
+	    }
+	    RETPUSHNO;
+	}
+	/* integer increment */
+	if (cx->blk_loop.iterix > cx->blk_loop.itermax)
+	    RETPUSHNO;
+
+	/* we need a fresh SV every time so that loop body sees a
+	 * completely new SV for closures/references to work as they
+	 * used to */
+	SvREFCNT_dec(*cx->blk_loop.itervar);
+	*cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++);
+	RETPUSHYES;
+    }
+
+    /* iterate array */
     if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av)))
 	RETPUSHNO;
 
@@ -1469,6 +1561,10 @@ PP(pp_subst)
     s = SvPV(TARG, len);
     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
 	force_on_match = 1;
+    rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
+		 (tainted && (pm->op_pmflags & PMf_RETAINT)));
+    if (tainted)
+	rxtainted |= 2;
     TAINT_NOT;
 
   force_it:
@@ -1504,7 +1600,7 @@ PP(pp_subst)
 	    }
 	    else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min, 
 				     (unsigned char*)strend,
-				     rx->check_substr)))
+				     rx->check_substr, 0)))
 		goto nope;
 	    if (s && rx->check_offset_max < s - m) {
 		++BmUSEFUL(rx->check_substr);
@@ -1540,7 +1636,7 @@ PP(pp_subst)
     /* can do inplace substitution? */
     if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR))
 	&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
-	if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+	if (!CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
 	    SPAGAIN;
 	    PUSHs(&sv_no);
 	    LEAVE_SCOPE(oldsave);
@@ -1555,7 +1651,7 @@ PP(pp_subst)
 	curpm = pm;
 	SvSCREAM_off(TARG);	/* disable possible screamer */
 	if (once) {
-	    rxtainted = RX_MATCH_TAINTED(rx);
+	    rxtainted |= RX_MATCH_TAINTED(rx);
 	    if (rx->subbase) {
 		m = orig + (rx->startp[0] - rx->subbase);
 		d = orig + (rx->endp[0] - rx->subbase);
@@ -1596,12 +1692,11 @@ PP(pp_subst)
 	    else {
 		sv_chop(TARG, d);
 	    }
-	    TAINT_IF(rxtainted);
+	    TAINT_IF(rxtainted & 1);
 	    SPAGAIN;
 	    PUSHs(&sv_yes);
 	}
 	else {
-	    rxtainted = 0;
 	    do {
 		if (iters++ > maxiters)
 		    DIE("Substitution loop");
@@ -1618,18 +1713,19 @@ PP(pp_subst)
 		    d += clen;
 		}
 		s = rx->endp[0];
-	    } while (regexec_flags(rx, s, strend, orig, s == m,
+	    } while (CALLREGEXEC(rx, s, strend, orig, s == m,
 			      Nullsv, NULL, 0)); /* don't match same null twice */
 	    if (s != d) {
 		i = strend - s;
 		SvCUR_set(TARG, d - SvPVX(TARG) + i);
 		Move(s, d, i+1, char);		/* include the NUL */
 	    }
-	    TAINT_IF(rxtainted);
+	    TAINT_IF(rxtainted & 1);
 	    SPAGAIN;
 	    PUSHs(sv_2mortal(newSViv((I32)iters)));
 	}
 	(void)SvPOK_only(TARG);
+	TAINT_IF(rxtainted);
 	if (SvSMAGICAL(TARG)) {
 	    PUTBACK;
 	    mg_set(TARG);
@@ -1640,13 +1736,13 @@ PP(pp_subst)
 	RETURN;
     }
 
-    if (regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+    if (CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
 	if (force_on_match) {
 	    force_on_match = 0;
 	    s = SvPV_force(TARG, len);
 	    goto force_it;
 	}
-	rxtainted = RX_MATCH_TAINTED(rx);
+	rxtainted |= RX_MATCH_TAINTED(rx);
 	dstr = NEWSV(25, len);
 	sv_setpvn(dstr, m, s-m);
 	curpm = pm;
@@ -1674,11 +1770,9 @@ PP(pp_subst)
 		sv_catpvn(dstr, c, clen);
 	    if (once)
 		break;
-	} while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
+	} while (CALLREGEXEC(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
 	sv_catpvn(dstr, s, strend - s);
 
-	TAINT_IF(rxtainted);
-
 	(void)SvOOK_off(TARG);
 	Safefree(SvPVX(TARG));
 	SvPVX(TARG) = SvPVX(dstr);
@@ -1687,11 +1781,14 @@ PP(pp_subst)
 	SvPVX(dstr) = 0;
 	sv_free(dstr);
 
+	TAINT_IF(rxtainted & 1);
+	SPAGAIN;
+	PUSHs(sv_2mortal(newSViv((I32)iters)));
+
 	(void)SvPOK_only(TARG);
+	TAINT_IF(rxtainted);
 	SvSETMAGIC(TARG);
 	SvTAINT(TARG);
-	SPAGAIN;
-	PUSHs(sv_2mortal(newSViv((I32)iters)));
 	LEAVE_SCOPE(oldsave);
 	RETURN;
     }
@@ -1764,9 +1861,19 @@ PP(pp_leavesub)
     TAINT_NOT;
     if (gimme == G_SCALAR) {
 	MARK = newsp + 1;
-	if (MARK <= SP)
-	    *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
-	else {
+	if (MARK <= SP) {
+	    if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+		if (SvTEMP(TOPs)) {
+		    *MARK = SvREFCNT_inc(TOPs);
+		    FREETMPS;
+		    sv_2mortal(*MARK);
+		} else {
+		    FREETMPS;
+		    *MARK = sv_mortalcopy(TOPs);
+		}
+	    } else
+		*MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+	} else {
 	    MEXTEND(MARK, 0);
 	    *MARK = &sv_undef;
 	}
@@ -1789,31 +1896,39 @@ PP(pp_leavesub)
     return pop_return();
 }
 
-static CV *
+STATIC CV *
 get_db_sub(SV **svp, CV *cv)
 {
     dTHR;
-    SV *oldsv = *svp;
-    GV *gv;
+    SV *dbsv = GvSV(DBsub);
+
+    if (!PERLDB_SUB_NN) {
+	GV *gv = CvGV(cv);
 
-    *svp = GvSV(DBsub);
-    save_item(*svp);
-    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(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv)
-    		&& (gv = (GV*)oldsv) ))) {
-	/* Use GV from the stack as a fallback. */
-	/* GV is potentially non-unique, or contain different CV. */
-	sv_setsv(*svp, newRV((SV*)cv));
+	save_item(dbsv);
+	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) ))) {
+	    /* Use GV from the stack as a fallback. */
+	    /* GV is potentially non-unique, or contain different CV. */
+	    sv_setsv(dbsv, newRV((SV*)cv));
+	}
+	else {
+	    gv_efullname3(dbsv, gv, Nullch);
+	}
     }
     else {
-	gv_efullname3(*svp, gv, Nullch);
+	SvUPGRADE(dbsv, SVt_PVIV);
+	SvIOK_on(dbsv);
+	SAVEIV(SvIVX(dbsv));
+	SvIVX(dbsv) = (IV)cv;		/* Do it the quickest way  */
     }
-    cv = GvCV(DBsub);
+
     if (CvXSUB(cv))
 	curcopdb = curcop;
+    cv = GvCV(DBsub);
     return cv;
 }
 
@@ -1982,8 +2097,9 @@ PP(pp_entersub)
      	 * (3) instead of (2) so we'd have to clone. Would the fact
      	 * that we released the mutex more quickly make up for this?
      	 */
-	svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE);
-     	if (svp) {
+	if (threadnum &&
+	    (svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
+	{
 	    /* We already have a clone to use */
 	    MUTEX_UNLOCK(CvMUTEXP(cv));
 	    cv = *(CV**)svp;
@@ -2086,7 +2202,7 @@ PP(pp_entersub)
 		curcopdb = NULL;
 	    }
 	    /* Do we need to open block here? XXXX */
-	    (void)(*CvXSUB(cv))(cv);
+	    (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
 
 	    /* Enforce some sanity in scalar context. */
 	    if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) {
@@ -2242,6 +2358,7 @@ PP(pp_aelem)
     AV* av = (AV*)POPs;
     U32 lval = op->op_flags & OPf_MOD;
     U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
+    SV *sv;
 
     if (elem > 0)
 	elem -= curcop->cop_arybase;
@@ -2268,7 +2385,10 @@ PP(pp_aelem)
 	else if (op->op_private & OPpDEREF)
 	    vivify_ref(*svp, op->op_private & OPpDEREF);
     }
-    PUSHs(svp ? *svp : &sv_undef);
+    sv = (svp ? *svp : &sv_undef);
+    if (!lval && SvGMAGICAL(sv))	/* see note in pp_helem() */
+	sv = sv_mortalcopy(sv);
+    PUSHs(sv);
     RETURN;
 }
 
@@ -2339,7 +2459,9 @@ PP(pp_method)
 	    !(ob=(SV*)GvIO(iogv)))
 	{
 	    if (!packname || !isIDFIRST(*packname))
-  DIE("Can't call method \"%s\" without a package or object reference", name);
+		DIE("Can't call method \"%s\" %s", name,
+		    SvOK(sv)? "without a package or object reference"
+			    : "on an undefined value");
 	    stash = gv_stashpvn(packname, packlen, TRUE);
 	    goto fetch;
 	}