X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=e781dcc0d54d601917406e3cbde47368edf5909a;hb=080c2decc1c1070c5ce819e741a37407aa249711;hp=63f8b9dc43f3dcc9eaa51ad3b2b6396d0e3ddde3;hpb=ed25273444c5542e4865fbe422e026b78ba33b80;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index 63f8b9d..e781dcc 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1,6 +1,7 @@
 /*    pp_hot.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -136,11 +137,12 @@ PP(pp_concat)
     bool lbyte;
     STRLEN rlen;
     char* rpv = SvPV(right, rlen);	/* mg_get(right) happens here */
-    bool rbyte = !SvUTF8(right);
+    bool rbyte = !SvUTF8(right), rcopied = FALSE;
 
     if (TARG == right && right != left) {
 	right = sv_2mortal(newSVpvn(rpv, rlen));
 	rpv = SvPV(right, rlen);	/* no point setting UTF8 here */
+	rcopied = TRUE;
     }
 
     if (TARG != left) {
@@ -176,6 +178,8 @@ PP(pp_concat)
 	if (lbyte)
 	    sv_utf8_upgrade_nomg(TARG);
 	else {
+	    if (!rcopied)
+		right = sv_2mortal(newSVpvn(rpv, rlen));
 	    sv_utf8_upgrade_nomg(right);
 	    rpv = SvPV(right, rlen);
 	}
@@ -682,6 +686,9 @@ PP(pp_rv2av)
 	    SETs((SV*)av);
 	    RETURN;
 	}
+	else if (PL_op->op_flags & OPf_MOD
+		&& PL_op->op_private & OPpLVAL_INTRO)
+	    Perl_croak(aTHX_ PL_no_localize_ref);
     }
     else {
 	if (SvTYPE(sv) == SVt_PVAV) {
@@ -801,11 +808,14 @@ PP(pp_rv2hv)
 	    RETURN;
 	}
 	else if (LVRET) {
-	    if (GIMME == G_SCALAR)
+	    if (GIMME != G_SCALAR)
 		Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 	    SETs((SV*)hv);
 	    RETURN;
 	}
+	else if (PL_op->op_flags & OPf_MOD
+		&& PL_op->op_private & OPpLVAL_INTRO)
+	    Perl_croak(aTHX_ PL_no_localize_ref);
     }
     else {
 	if (SvTYPE(sv) == SVt_PVHV) {
@@ -1224,7 +1234,7 @@ PP(pp_match)
     if (SvSCREAM(TARG))
 	r_flags |= REXEC_SCREAM;
 
-    if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+    if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
 	SAVEINT(PL_multiline);
 	PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
@@ -1485,8 +1495,10 @@ Perl_do_readline(pTHX)
 	}
 	if (gimme == G_SCALAR) {
 	    /* undef TARG, and push that undefined value */
-	    SV_CHECK_THINKFIRST_COW_DROP(TARG);
-	    (void)SvOK_off(TARG);
+	    if (type != OP_RCATLINE) {
+		SV_CHECK_THINKFIRST_COW_DROP(TARG);
+		(void)SvOK_off(TARG);
+	    }
 	    PUSHTARG;
 	}
 	RETURN;
@@ -1498,7 +1510,7 @@ Perl_do_readline(pTHX)
 	    sv_unref(sv);
 	(void)SvUPGRADE(sv, SVt_PV);
 	tmplen = SvLEN(sv);	/* remember if already alloced */
-	if (!tmplen)
+	if (!tmplen && !SvREADONLY(sv))
 	    Sv_Grow(sv, 80);	/* try short-buffering it */
 	offset = 0;
 	if (type == OP_RCATLINE && SvOK(sv)) {
@@ -1547,8 +1559,10 @@ Perl_do_readline(pTHX)
 		}
 	    }
 	    if (gimme == G_SCALAR) {
-		SV_CHECK_THINKFIRST_COW_DROP(TARG);
-		(void)SvOK_off(TARG);
+		if (type != OP_RCATLINE) {
+		    SV_CHECK_THINKFIRST_COW_DROP(TARG);
+		    (void)SvOK_off(TARG);
+		}
 		SPAGAIN;
 		PUSHTARG;
 	    }
@@ -1845,6 +1859,12 @@ PP(pp_iter)
     else {
 	sv = AvARRAY(av)[++cx->blk_loop.iterix];
     }
+    if (sv && SvREFCNT(sv) == 0) {
+	*itersvp = Nullsv;
+	Perl_croak(aTHX_
+	    "Use of freed value in iteration (perhaps you modified the iterated array within the loop?)");
+    }
+
     if (sv)
 	SvTEMP_off(sv);
     else
@@ -1901,6 +1921,7 @@ PP(pp_subst)
 #ifdef PERL_COPY_ON_WRITE
     bool is_cow;
 #endif
+    SV *nsv = Nullsv;
 
     /* known replacement string? */
     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
@@ -1958,7 +1979,7 @@ PP(pp_subst)
 	       ? REXEC_COPY_STR : 0;
     if (SvSCREAM(TARG))
 	r_flags |= REXEC_SCREAM;
-    if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+    if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
 	SAVEINT(PL_multiline);
 	PL_multiline = pm->op_pmflags & PMf_MULTILINE;
     }
@@ -1986,7 +2007,7 @@ PP(pp_subst)
     if (dstr) {
 	/* replacement needing upgrading? */
 	if (DO_UTF8(TARG) && !doutf8) {
-	     SV *nsv = sv_newmortal();
+	     nsv = sv_newmortal();
 	     SvSetSV(nsv, dstr);
 	     if (PL_encoding)
 		  sv_recode_to_utf8(nsv, PL_encoding);
@@ -2011,7 +2032,8 @@ PP(pp_subst)
 	&& !is_cow
 #endif
 	&& (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
-	&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
+	&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
+	&& (!doutf8 || SvUTF8(TARG))) {
 	if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
 			 r_flags | REXEC_CHECKED))
 	{
@@ -2139,6 +2161,7 @@ PP(pp_subst)
 	if (!c) {
 	    register PERL_CONTEXT *cx;
 	    SPAGAIN;
+	    ReREFCNT_inc(rx);
 	    PUSHSUBST(cx);
 	    RETURNOP(cPMOP->op_pmreplroot);
 	}
@@ -2155,7 +2178,10 @@ PP(pp_subst)
 		strend = s + (strend - m);
 	    }
 	    m = rx->startp[0] + orig;
-	    sv_catpvn(dstr, s, m-s);
+	    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;
 	    if (clen)
 		sv_catpvn(dstr, c, clen);
@@ -2163,12 +2189,8 @@ PP(pp_subst)
 		break;
 	} while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
 			     TARG, NULL, r_flags));
-	if (doutf8 && !DO_UTF8(dstr)) {
-	    SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
-	    
-	    sv_utf8_upgrade(nsv);
-	    sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
-	}
+	if (doutf8 && !DO_UTF8(TARG))
+	    sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
 	else
 	    sv_catpvn(dstr, s, strend - s);
 
@@ -2306,10 +2328,10 @@ PP(pp_leavesub)
     }
     PUTBACK;
 
+    LEAVE;
     POPSUB(cx,sv);	/* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
-    LEAVE;
     LEAVESUB(sv);
     return pop_return();
 }
@@ -2362,9 +2384,9 @@ PP(pp_leavesublv)
 	 * the refcounts so the caller gets a live guy. Cannot set
 	 * TEMP, so sv_2mortal is out of question. */
 	if (!CvLVALUE(cx->blk_sub.cv)) {
+	    LEAVE;
 	    POPSUB(cx,sv);
 	    PL_curpm = newpm;
-	    LEAVE;
 	    LEAVESUB(sv);
 	    DIE(aTHX_ "Can't modify non-lvalue subroutine call");
 	}
@@ -2373,9 +2395,9 @@ PP(pp_leavesublv)
 	    EXTEND_MORTAL(1);
 	    if (MARK == SP) {
 		if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+		    LEAVE;
 		    POPSUB(cx,sv);
 		    PL_curpm = newpm;
-		    LEAVE;
 		    LEAVESUB(sv);
 		    DIE(aTHX_ "Can't return %s from lvalue subroutine",
 			SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
@@ -2388,9 +2410,9 @@ PP(pp_leavesublv)
 		}
 	    }
 	    else {			/* Should not happen? */
+		LEAVE;
 		POPSUB(cx,sv);
 		PL_curpm = newpm;
-		LEAVE;
 		LEAVESUB(sv);
 		DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
 		    (MARK > SP ? "Empty array" : "Array"));
@@ -2404,9 +2426,9 @@ PP(pp_leavesublv)
 		    && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
 		    /* Might be flattened array after $#array =  */
 		    PUTBACK;
+		    LEAVE;
 		    POPSUB(cx,sv);
 		    PL_curpm = newpm;
-		    LEAVE;
 		    LEAVESUB(sv);
 		    DIE(aTHX_ "Can't return a %s from lvalue subroutine",
 			SvREADONLY(TOPs) ? "readonly value" : "temporary");
@@ -2458,10 +2480,10 @@ PP(pp_leavesublv)
     }
     PUTBACK;
 
+    LEAVE;
     POPSUB(cx,sv);	/* Stack values are safe: release CV and @_ ... */
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
-    LEAVE;
     LEAVESUB(sv);
     return pop_return();
 }
@@ -2580,6 +2602,9 @@ PP(pp_entersub)
 
     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);
+	
 	cv = get_db_sub(&sv, cv);
 	if (!cv)
 	    DIE(aTHX_ "No DBsub routine");
@@ -2909,8 +2934,18 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 
 	/* this isn't a reference */
 	packname = Nullch;
+
+        if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
+          HE* he;
+	  he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
+          if (he) { 
+            stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+            goto fetch;
+          }
+        }
+
 	if (!SvOK(sv) ||
-	    !(packname = SvPV(sv, packlen)) ||
+	    !(packname) ||
 	    !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
 	    !(ob=(SV*)GvIO(iogv)))
 	{
@@ -2929,6 +2964,10 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	    stash = gv_stashpvn(packname, packlen, FALSE);
 	    if (!stash)
 		packsv = sv;
+            else {
+	        SV* ref = newSViv(PTR2IV(stash));
+	        hv_store(PL_stashcache, packname, packlen, ref, 0);
+	    }
 	    goto fetch;
 	}
 	/* it _is_ a filehandle name -- replace with a reference */
@@ -2985,7 +3024,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	    /* the method name is unqualified or starts with SUPER:: */ 
 	    packname = sep ? CopSTASHPV(PL_curcop) :
 		stash ? HvNAME(stash) : packname;
-	    packlen = strlen(packname);
+	    if (!packname)
+		Perl_croak(aTHX_
+			   "Can't use anonymous symbol table for method lookup");
+	    else
+		packlen = strlen(packname);
 	}
 	else {
 	    /* the method name is qualified */