X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=0f1fee980a96c7ba577e1e2ce4f3c5e31e712468;hb=53d8b1b83d50124b4c90921bb6086ec256ae063a;hp=d02f57eab7972f3e40645ab6b9f931f869cb0930;hpb=792b2c1636f29e9c8ddbd03dbcee9083ba541eed;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/pp_hot.c b/pp_hot.c
index d02f57e..0f1fee9 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1,6 +1,6 @@
 /*    pp_hot.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -76,8 +76,10 @@ PP(pp_stringify)
     char *s;
     s = SvPV(TOPs,len);
     sv_setpvn(TARG,s,len);
-    if (SvUTF8(TOPs) && !IN_BYTE)
+    if (SvUTF8(TOPs))
 	SvUTF8_on(TARG);
+    else
+	SvUTF8_off(TARG);
     SETTARG;
     RETURN;
 }
@@ -140,103 +142,52 @@ PP(pp_concat)
   djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
   {
     dPOPTOPssrl;
-    STRLEN len;
-    U8 *s;
-    bool left_utf8;
-    bool right_utf8;
+    SV* rcopy = Nullsv;
 
-    if (TARG == right && SvGMAGICAL(right))
-        mg_get(right);
     if (SvGMAGICAL(left))
         mg_get(left);
+    if (TARG == right && SvGMAGICAL(right))
+        mg_get(right);
 
-    left_utf8  = DO_UTF8(left);
-    right_utf8 = DO_UTF8(right);
-
-    if (left_utf8 != right_utf8) {
-        if (TARG == right && !right_utf8) {
-            sv_utf8_upgrade(TARG); /* Now straight binary copy */
-            SvUTF8_on(TARG);
-        }
-        else {
-            /* Set TARG to PV(left), then add right */
-            U8 *l, *c, *olds = NULL;
-            STRLEN targlen;
-	    s = (U8*)SvPV(right,len);
-	    right_utf8 |= DO_UTF8(right);
-            if (TARG == right) {
-		/* Take a copy since we're about to overwrite TARG */
-		olds = s = (U8*)savepvn((char*)s, len);
-	    }
-	    if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
-	        if (SvREADONLY(left))
-		    left = sv_2mortal(newSVsv(left));
-		else
-		    sv_setpv(left, "");	/* Suppress warning. */
-	    }
-            l = (U8*)SvPV(left, targlen);
-	    left_utf8 |= DO_UTF8(left);
-            if (TARG != left)
-                sv_setpvn(TARG, (char*)l, targlen);
-            if (!left_utf8)
-                sv_utf8_upgrade(TARG);
-            /* Extend TARG to length of right (s) */
-            targlen = SvCUR(TARG) + len;
-            if (!right_utf8) {
-                /* plus one for each hi-byte char if we have to upgrade */
-                for (c = s; c < s + len; c++)  {
-                    if (UTF8_IS_CONTINUED(*c))
-                        targlen++;
-                }
-            }
-            SvGROW(TARG, targlen+1);
-            /* And now copy, maybe upgrading right to UTF8 on the fly */
-	    if (right_utf8)
-		Copy(s, SvEND(TARG), len, U8);
-	    else {
-		for (c = (U8*)SvEND(TARG); len--; s++)
-		    c = uv_to_utf8(c, *s);
-	    }
-            SvCUR_set(TARG, targlen);
-            *SvEND(TARG) = '\0';
-            SvUTF8_on(TARG);
-            SETs(TARG);
-	    Safefree(olds);
-            RETURN;
-        }
-    }
-
-    if (TARG != left) {
-	s = (U8*)SvPV(left,len);
-	if (TARG == right) {
-	    sv_insert(TARG, 0, 0, (char*)s, len);
-	    SETs(TARG);
-	    RETURN;
+    if (TARG == right && left != right)
+	/* Clone since otherwise we cannot prepend. */
+	rcopy = sv_2mortal(newSVsv(right));
+
+    if (TARG != left)
+	sv_setsv(TARG, left);
+
+    if (TARG == right) {
+	if (left == right) {
+	    /*  $right = $right . $right; */
+	    STRLEN rlen;
+	    char *rpv = SvPV(right, rlen);
+
+	    sv_catpvn(TARG, rpv, rlen);
 	}
-	sv_setpvn(TARG, (char *)s, len);
+	else /* $right = $left  . $right; */
+	    sv_catsv(TARG, rcopy);
     }
-    else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
-	sv_setpv(TARG, "");	/* Suppress warning. */
-    s = (U8*)SvPV(right,len);
-    if (SvOK(TARG)) {
+    else {
+	if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */
+	    sv_setpv(TARG, "");
+	/* $other = $left . $right; */
+	/* $left  = $left . $right; */
+	sv_catsv(TARG, right);
+    }
+
 #if defined(PERL_Y2KWARN)
-	if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
-	    STRLEN n;
-	    char *s = SvPV(TARG,n);
-	    if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
-		&& (n == 2 || !isDIGIT(s[n-3])))
-	    {
-		Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
-			    "about to append an integer to '19'");
-	    }
+    if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
+	STRLEN n;
+	char *s = SvPV(TARG,n);
+	if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
+	    && (n == 2 || !isDIGIT(s[n-3])))
+	{
+	    Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
+			"about to append an integer to '19'");
 	}
-#endif
-	sv_catpvn(TARG, (char *)s, len);
     }
-    else
-	sv_setpvn(TARG, (char *)s, len);	/* suppress warning */
-    if (left_utf8)
-	SvUTF8_on(TARG);
+#endif
+
     SETTARG;
     RETURN;
   }
@@ -289,7 +240,7 @@ PP(pp_eq)
 	if (SvIOK(TOPm1s)) {
 	    bool auvok = SvUOK(TOPm1s);
 	    bool buvok = SvUOK(TOPs);
-	    
+	
 	    if (!auvok && !buvok) { /* ## IV == IV ## */
 		IV aiv = SvIVX(TOPm1s);
 		IV biv = SvIVX(TOPs);
@@ -416,7 +367,7 @@ PP(pp_add)
 	if (SvIOK(TOPm1s)) {
 	    bool auvok = SvUOK(TOPm1s);
 	    bool buvok = SvUOK(TOPs);
-	    
+	
 	    if (!auvok && !buvok) { /* ## IV + IV ## */
 		IV aiv = SvIVX(TOPm1s);
 		IV biv = SvIVX(TOPs);
@@ -459,7 +410,7 @@ PP(pp_add)
 		    aiv = SvIVX(TOPs);
 		    buv = SvUVX(TOPm1s);
 		}
-	    
+	
 		if (aiv >= 0) {
 		    UV result = (UV)aiv + buv;
 		    if (result >= buv) {
@@ -660,6 +611,12 @@ PP(pp_rv2av)
 	    SETs((SV*)av);
 	    RETURN;
 	}
+	else if (LVRET) {
+	    if (GIMME == G_SCALAR)
+		Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+	    SETs((SV*)av);
+	    RETURN;
+	}
     }
     else {
 	if (SvTYPE(sv) == SVt_PVAV) {
@@ -668,6 +625,13 @@ PP(pp_rv2av)
 		SETs((SV*)av);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return array to lvalue"
+			       " scalar context");
+		SETs((SV*)av);
+		RETURN;
+	    }
 	}
 	else {
 	    GV *gv;
@@ -721,6 +685,13 @@ PP(pp_rv2av)
 		SETs((SV*)av);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return array to lvalue"
+			       " scalar context");
+		SETs((SV*)av);
+		RETURN;
+	    }
 	}
     }
 
@@ -764,6 +735,12 @@ PP(pp_rv2hv)
 	    SETs((SV*)hv);
 	    RETURN;
 	}
+	else if (LVRET) {
+	    if (GIMME == G_SCALAR)
+		Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+	    SETs((SV*)hv);
+	    RETURN;
+	}
     }
     else {
 	if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
@@ -772,6 +749,13 @@ PP(pp_rv2hv)
 		SETs((SV*)hv);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return hash to lvalue"
+			       " scalar context");
+		SETs((SV*)hv);
+		RETURN;
+	    }
 	}
 	else {
 	    GV *gv;
@@ -825,6 +809,13 @@ PP(pp_rv2hv)
 		SETs((SV*)hv);
 		RETURN;
 	    }
+	    else if (LVRET) {
+		if (GIMME == G_SCALAR)
+		    Perl_croak(aTHX_ "Can't return hash to lvalue"
+			       " scalar context");
+		SETs((SV*)hv);
+		RETURN;
+	    }
 	}
     }
 
@@ -1240,7 +1231,8 @@ play_it_again:
 	if (update_minmatch++)
 	    minmatch = had_zerolen;
     }
-    if (rx->reganch & RE_USE_INTUIT) {
+    if (rx->reganch & RE_USE_INTUIT &&
+	DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
 	s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
 
 	if (!s)
@@ -1337,7 +1329,13 @@ yup:					/* Confirmed by INTUIT */
     if (global) {
 	rx->subbeg = truebase;
 	rx->startp[0] = s - truebase;
-	rx->endp[0] = s - truebase + rx->minlen;
+	if (DO_UTF8(PL_reg_sv)) {
+	    char *t = (char*)utf8_hop((U8*)s, rx->minlen);
+	    rx->endp[0] = t - truebase;
+	}
+	else {
+	    rx->endp[0] = s - truebase + rx->minlen;
+	}
 	rx->sublen = strend - truebase;
 	goto gotcha;
     }
@@ -1574,7 +1572,7 @@ PP(pp_helem)
     SV **svp;
     SV *keysv = POPs;
     HV *hv = (HV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD;
+    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
@@ -1619,8 +1617,8 @@ PP(pp_helem)
 		if (!preeminent) {
 		    STRLEN keylen;
 		    char *key = SvPV(keysv, keylen);
-		    save_delete(hv, key, keylen);
-		} else 
+		    SAVEDELETE(hv, savepvn(key,keylen), keylen);
+		} else
 		    save_helem(hv, keysv, svp);
             }
 	}
@@ -1850,13 +1848,13 @@ PP(pp_subst)
     if (PL_tainted)
 	rxtainted |= 2;
     TAINT_NOT;
-    
+
   force_it:
     if (!pm || !s)
 	DIE(aTHX_ "panic: pp_subst");
 
     strend = s + len;
-    slen = do_utf8 ? utf8_length(s, strend) : len;
+    slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
     maxiters = 2 * slen + 10;	/* We can match twice at each
 				   position, once with zero-length,
 				   second time with non-zero. */
@@ -2000,6 +1998,8 @@ PP(pp_subst)
     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
 		    r_flags | REXEC_CHECKED))
     {
+	bool isutf8;
+
 	if (force_on_match) {
 	    force_on_match = 0;
 	    s = SvPV_force(TARG, len);
@@ -2045,6 +2045,7 @@ PP(pp_subst)
 	SvPVX(TARG) = SvPVX(dstr);
 	SvCUR_set(TARG, SvCUR(dstr));
 	SvLEN_set(TARG, SvLEN(dstr));
+	isutf8 = DO_UTF8(dstr);
 	SvPVX(dstr) = 0;
 	sv_free(dstr);
 
@@ -2053,6 +2054,8 @@ PP(pp_subst)
 	PUSHs(sv_2mortal(newSViv((I32)iters)));
 
 	(void)SvPOK_only(TARG);
+	if (isutf8)
+	    SvUTF8_on(TARG);
 	TAINT_IF(rxtainted);
 	SvSETMAGIC(TARG);
 	SvTAINT(TARG);
@@ -2822,7 +2825,7 @@ PP(pp_aelem)
     SV* elemsv = POPs;
     IV elem = SvIV(elemsv);
     AV* av = (AV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD;
+    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
     SV *sv;
 
@@ -2950,7 +2953,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	    !(ob=(SV*)GvIO(iogv)))
 	{
 	    if (!packname ||
-		((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
+		((UTF8_IS_START(*packname) && DO_UTF8(sv))
 		    ? !isIDFIRST_utf8((U8*)packname)
 		    : !isIDFIRST(*packname)
 		))