X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doop.c;h=5a41f6ac42deec56d6787b93ec6ffc862a3df456;hb=05106a66598c0f7468245082baf57f74ae89945f;hp=8600b7c93e5334827fb717e7496411aa228aec5a;hpb=21304a3b8e5f090f8ff24bdbacf7bbfe2c05388d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/doop.c b/doop.c
index 8600b7c..5a41f6a 100644
--- a/doop.c
+++ b/doop.c
@@ -1,6 +1,7 @@
 /*    doop.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 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.
@@ -41,12 +42,12 @@ S_do_trans_simple(pTHX_ SV *sv)
     s = (U8*)SvPV(sv, len);
     send = s + len;
 
-    /* First, take care of non-UTF8 input strings, because they're easy */
+    /* First, take care of non-UTF-8 input strings, because they're easy */
     if (!SvUTF8(sv)) {
 	while (s < send) {
 	    if ((ch = tbl[*s]) >= 0) {
 		matches++;
-		*s++ = ch;
+		*s++ = (U8)ch;
 	    }
 	    else
 		s++;
@@ -73,7 +74,7 @@ S_do_trans_simple(pTHX_ SV *sv)
             s += ulen;
         }
 	else { /* No match -> copy */
-	    Copy(s, d, ulen, U8);
+	    Move(s, d, ulen, U8);
 	    d += ulen;
 	    s += ulen;
         }
@@ -159,7 +160,7 @@ S_do_trans_complex(pTHX_ SV *sv)
 	    U8* p = send;
 	    while (s < send) {
 		if ((ch = tbl[*s]) >= 0) {
-		    *d = ch;
+		    *d = (U8)ch;
 		    matches++;
 		    if (p != d - 1 || *p != *d)
 			p = d++;
@@ -175,7 +176,7 @@ S_do_trans_complex(pTHX_ SV *sv)
 	    while (s < send) {
 	        if ((ch = tbl[*s]) >= 0) {
 		    matches++;
-		    *d++ = ch;
+		    *d++ = (U8)ch;
 		}
 		else if (ch == -1)	/* -1 is unmapped character */
 		    *d++ = *s;
@@ -217,9 +218,9 @@ S_do_trans_complex(pTHX_ SV *sv)
 			    ch = (rlen == 0) ? comp :
 				(comp - 0x100 < rlen) ?
 				tbl[comp+1] : tbl[0x100+rlen];
-			    if (ch != pch) {
+			    if ((UV)ch != pch) {
 				d = uvchr_to_utf8(d, ch);
-				pch = ch;
+				pch = (UV)ch;
 			    }
 			    s += len;
 			    continue;
@@ -228,9 +229,9 @@ S_do_trans_complex(pTHX_ SV *sv)
 		}
 		else if ((ch = tbl[comp]) >= 0) {
 		    matches++;
-		    if (ch != pch) {
+		    if ((UV)ch != pch) {
 		        d = uvchr_to_utf8(d, ch);
-		        pch = ch;
+		        pch = (UV)ch;
 		    }
 		    s += len;
 		    continue;
@@ -251,7 +252,7 @@ S_do_trans_complex(pTHX_ SV *sv)
 	        UV comp = utf8_to_uvchr(s, &len);
 		if (comp > 0xff) {
 		    if (!complement) {
-			Copy(s, d, len, U8);
+			Move(s, d, len, U8);
 			d += len;
 		    }
 		    else {
@@ -351,7 +352,7 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)
 	}
 	else if (uv == none) {
 	    int i = UTF8SKIP(s);
-	    Copy(s, d, i, U8);
+	    Move(s, d, i, U8);
 	    d += i;
 	    s += i;
 	}
@@ -510,7 +511,7 @@ S_do_trans_complex_utf8(pTHX_ SV *sv)
 	    }
 	    else if (uv == none) {	/* "none" is unmapped character */
 		int i = UTF8SKIP(s);
-		Copy(s, d, i, U8);
+		Move(s, d, i, U8);
 		d += i;
 		s += i;
 		puv = 0xfeedface;
@@ -529,7 +530,7 @@ S_do_trans_complex_utf8(pTHX_ SV *sv)
 		    STRLEN len;
 		    uv = utf8_to_uvuni(s, &len);
 		    if (uv != puv) {
-			Copy(s, d, len, U8);
+			Move(s, d, len, U8);
 			d += len;
 			puv = uv;
 		    }
@@ -561,7 +562,7 @@ S_do_trans_complex_utf8(pTHX_ SV *sv)
 	    }
 	    else if (uv == none) {	/* "none" is unmapped character */
 		int i = UTF8SKIP(s);
-		Copy(s, d, i, U8);
+		Move(s, d, i, U8);
 		d += i;
 		s += i;
 		continue;
@@ -599,16 +600,20 @@ Perl_do_trans(pTHX_ SV *sv)
     I32 hasutf = (PL_op->op_private &
                     (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
 
-    if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
-	Perl_croak(aTHX_ PL_no_modify);
-
+    if (SvREADONLY(sv)) {
+        if (SvIsCOW(sv))
+            sv_force_normal_flags(sv, 0);
+        if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
+            Perl_croak(aTHX_ PL_no_modify);
+    }
     (void)SvPV(sv, len);
     if (!len)
 	return 0;
-    if (!SvPOKp(sv))
-	(void)SvPV_force(sv, len);
-    if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
+    if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
+	if (!SvPOKp(sv))
+	    (void)SvPV_force(sv, len);
 	(void)SvPOK_only_UTF8(sv);
+    }
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 
@@ -694,6 +699,9 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
     char *pat = SvPV(*sarg, patlen);
     bool do_taint = FALSE;
 
+    SvUTF8_off(sv);
+    if (DO_UTF8(*sarg))
+        SvUTF8_on(sv);
     sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
     SvSETMAGIC(sv);
     if (do_taint)
@@ -724,18 +732,18 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 	else {
 	    offset >>= 3;	/* turn into byte offset */
 	    if (size == 16) {
-		if (offset >= srclen)
+		if ((STRLEN)offset >= srclen)
 		    retnum = 0;
 		else
 		    retnum = (UV) s[offset] <<  8;
 	    }
 	    else if (size == 32) {
-		if (offset >= srclen)
+		if ((STRLEN)offset >= srclen)
 		    retnum = 0;
-		else if (offset + 1 >= srclen)
+		else if ((STRLEN)(offset + 1) >= srclen)
 		    retnum =
 			((UV) s[offset    ] << 24);
-		else if (offset + 2 >= srclen)
+		else if ((STRLEN)(offset + 2) >= srclen)
 		    retnum =
 			((UV) s[offset    ] << 24) +
 			((UV) s[offset + 1] << 16);
@@ -748,7 +756,7 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 #ifdef UV_IS_QUAD
 	    else if (size == 64) {
 		if (ckWARN(WARN_PORTABLE))
-		    Perl_warner(aTHX_ WARN_PORTABLE,
+		    Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 				"Bit vector size > 32 non-portable");
 		if (offset >= srclen)
 		    retnum = 0;
@@ -817,7 +825,7 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 #ifdef UV_IS_QUAD
 	else if (size == 64) {
 	    if (ckWARN(WARN_PORTABLE))
-		Perl_warner(aTHX_ WARN_PORTABLE,
+		Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 			    "Bit vector size > 32 non-portable");
 	    retnum =
 		((UV) s[offset    ] << 56) +
@@ -866,7 +874,7 @@ Perl_do_vecset(pTHX_ SV *sv)
     lval = SvUV(sv);
     offset = LvTARGOFF(sv);
     if (offset < 0)
-	Perl_croak(aTHX_ "Assigning to negative offset in vec");
+	Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
     size = LvTARGLEN(sv);
     if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
 	Perl_croak(aTHX_ "Illegal number of bits in vec");
@@ -890,30 +898,30 @@ Perl_do_vecset(pTHX_ SV *sv)
     else {
 	offset >>= 3;			/* turn into byte offset */
 	if (size == 8)
-	    s[offset  ] = lval         & 0xff;
+	    s[offset  ] = (U8)( lval        & 0xff);
 	else if (size == 16) {
-	    s[offset  ] = (lval >>  8) & 0xff;
-	    s[offset+1] = lval         & 0xff;
+	    s[offset  ] = (U8)((lval >>  8) & 0xff);
+	    s[offset+1] = (U8)( lval        & 0xff);
 	}
 	else if (size == 32) {
-	    s[offset  ] = (lval >> 24) & 0xff;
-	    s[offset+1] = (lval >> 16) & 0xff;
-	    s[offset+2] = (lval >>  8) & 0xff;
-	    s[offset+3] =  lval        & 0xff;
+	    s[offset  ] = (U8)((lval >> 24) & 0xff);
+	    s[offset+1] = (U8)((lval >> 16) & 0xff);
+	    s[offset+2] = (U8)((lval >>  8) & 0xff);
+	    s[offset+3] = (U8)( lval        & 0xff);
 	}
 #ifdef UV_IS_QUAD
 	else if (size == 64) {
 	    if (ckWARN(WARN_PORTABLE))
-		Perl_warner(aTHX_ WARN_PORTABLE,
+		Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 			    "Bit vector size > 32 non-portable");
-	    s[offset  ] = (lval >> 56) & 0xff;
-	    s[offset+1] = (lval >> 48) & 0xff;
-	    s[offset+2] = (lval >> 40) & 0xff;
-	    s[offset+3] = (lval >> 32) & 0xff;
-	    s[offset+4] = (lval >> 24) & 0xff;
-	    s[offset+5] = (lval >> 16) & 0xff;
-	    s[offset+6] = (lval >>  8) & 0xff;
-	    s[offset+7] =  lval        & 0xff;
+	    s[offset  ] = (U8)((lval >> 56) & 0xff);
+	    s[offset+1] = (U8)((lval >> 48) & 0xff);
+	    s[offset+2] = (U8)((lval >> 40) & 0xff);
+	    s[offset+3] = (U8)((lval >> 32) & 0xff);
+	    s[offset+4] = (U8)((lval >> 24) & 0xff);
+	    s[offset+5] = (U8)((lval >> 16) & 0xff);
+	    s[offset+6] = (U8)((lval >>  8) & 0xff);
+	    s[offset+7] = (U8)( lval        & 0xff);
 	}
 #endif
     }
@@ -947,8 +955,14 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
             do_chop(astr,hv_iterval(hv,entry));
         return;
     }
-    else if (SvREADONLY(sv))
-	Perl_croak(aTHX_ PL_no_modify);
+    else if (SvREADONLY(sv)) {
+        if (SvFAKE(sv)) {
+            /* SV is copy-on-write */
+	    sv_force_normal_flags(sv, 0);
+        }
+        if (SvREADONLY(sv))
+            Perl_croak(aTHX_ PL_no_modify);
+    }
     s = SvPV(sv, len);
     if (len && !SvPOK(sv))
 	s = SvPV_force(sv, len);
@@ -1017,8 +1031,14 @@ Perl_do_chomp(pTHX_ register SV *sv)
             count += do_chomp(hv_iterval(hv,entry));
         return count;
     }
-    else if (SvREADONLY(sv))
-	Perl_croak(aTHX_ PL_no_modify);
+    else if (SvREADONLY(sv)) {
+        if (SvFAKE(sv)) {
+            /* SV is copy-on-write */
+	    sv_force_normal_flags(sv, 0);
+        }
+        if (SvREADONLY(sv))
+            Perl_croak(aTHX_ PL_no_modify);
+    }
     s = SvPV(sv, len);
     if (s && len) {
 	s += --len;
@@ -1099,8 +1119,8 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
     else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
 	STRLEN n_a;
 	dc = SvPV_force(sv, n_a);
-	if (SvCUR(sv) < len) {
-	    dc = SvGROW(sv, len + 1);
+	if (SvCUR(sv) < (STRLEN)len) {
+	    dc = SvGROW(sv, (STRLEN)(len + 1));
 	    (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
 	}
 	if (optype != OP_BIT_AND && (left_utf || right_utf))
@@ -1238,9 +1258,9 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 		*dc++ = *lc++ | *rc++;
 	  mop_up:
 	    len = lensave;
-	    if (rightlen > len)
+	    if (rightlen > (STRLEN)len)
 		sv_catpvn(sv, rsave + len, rightlen - len);
-	    else if (leftlen > len)
+	    else if (leftlen > (STRLEN)len)
 		sv_catpvn(sv, lsave + len, leftlen - len);
 	    else
 		*SvEND(sv) = '\0';
@@ -1262,7 +1282,6 @@ Perl_do_kv(pTHX)
     I32 gimme = GIMME_V;
     I32 dokeys =   (PL_op->op_type == OP_KEYS);
     I32 dovalues = (PL_op->op_type == OP_VALUES);
-    I32 realhv = (SvTYPE(hv) == SVt_PVHV);
 
     if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
 	dokeys = dovalues = TRUE;
@@ -1277,7 +1296,7 @@ Perl_do_kv(pTHX)
 	RETURN;
     }
 
-    keys = realhv ? hv : avhv_keys((AV*)hv);
+    keys = hv;
     (void)hv_iterinit(keys);	/* always reset iterator regardless */
 
     if (gimme == G_VOID)
@@ -1318,12 +1337,13 @@ Perl_do_kv(pTHX)
     PUTBACK;	/* hv_iternext and hv_iterval might clobber stack_sp */
     while ((entry = hv_iternext(keys))) {
 	SPAGAIN;
-	if (dokeys)
-	    XPUSHs(hv_iterkeysv(entry));	/* won't clobber stack_sp */
+	if (dokeys) {
+	    SV* sv = hv_iterkeysv(entry);
+	    XPUSHs(sv);	/* won't clobber stack_sp */
+	}
 	if (dovalues) {
 	    PUTBACK;
-	    tmpstr = realhv ?
-		     hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
+	    tmpstr = hv_iterval(hv,entry);
 	    DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
 			    (unsigned long)HeHASH(entry),
 			    HvMAX(keys)+1,