X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doop.c;h=06b1b38d5c85f4e43518ecc9376448aab054bb26;hb=57a264f964d3bc3cfc103b72615b68710b3a4b9a;hp=7b5f751a2c79a4d4164aa2e612b3bb6c67c758af;hpb=864dbfa3ca8032ef66f7aa86961933b19b962357;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/doop.c b/doop.c
index 7b5f751..06b1b38 100644
--- a/doop.c
+++ b/doop.c
@@ -1,6 +1,6 @@
 /*    doop.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -20,7 +20,7 @@
 #endif
 
 STATIC I32
-do_trans_CC_simple(pTHX_ SV *sv)
+S_do_trans_CC_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -32,7 +32,7 @@ do_trans_CC_simple(pTHX_ SV *sv)
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-	croak("panic: do_trans");
+	Perl_croak(aTHX_ "panic: do_trans");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -50,7 +50,7 @@ do_trans_CC_simple(pTHX_ SV *sv)
 }
 
 STATIC I32
-do_trans_CC_count(pTHX_ SV *sv)
+S_do_trans_CC_count(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -61,7 +61,7 @@ do_trans_CC_count(pTHX_ SV *sv)
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-	croak("panic: do_trans");
+	Perl_croak(aTHX_ "panic: do_trans");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -76,7 +76,7 @@ do_trans_CC_count(pTHX_ SV *sv)
 }
 
 STATIC I32
-do_trans_CC_complex(pTHX_ SV *sv)
+S_do_trans_CC_complex(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -89,7 +89,7 @@ do_trans_CC_complex(pTHX_ SV *sv)
 
     tbl = (short*)cPVOP->op_pv;
     if (!tbl)
-	croak("panic: do_trans");
+	Perl_croak(aTHX_ "panic: do_trans");
 
     s = (U8*)SvPV(sv, len);
     send = s + len;
@@ -133,7 +133,7 @@ do_trans_CC_complex(pTHX_ SV *sv)
 }
 
 STATIC I32
-do_trans_UU_simple(pTHX_ SV *sv)
+S_do_trans_UU_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -185,7 +185,7 @@ do_trans_UU_simple(pTHX_ SV *sv)
 }
 
 STATIC I32
-do_trans_UU_count(pTHX_ SV *sv)
+S_do_trans_UU_count(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -212,7 +212,7 @@ do_trans_UU_count(pTHX_ SV *sv)
 }
 
 STATIC I32
-do_trans_UC_simple(pTHX_ SV *sv)
+S_do_trans_UC_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -265,7 +265,7 @@ do_trans_UC_simple(pTHX_ SV *sv)
 }
 
 STATIC I32
-do_trans_CU_simple(pTHX_ SV *sv)
+S_do_trans_CU_simple(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -282,7 +282,7 @@ do_trans_CU_simple(pTHX_ SV *sv)
     UV extra = none + 1;
     UV final;
     UV uv;
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     I32 bits = 16;
 
     s = (U8*)SvPV(sv, len);
@@ -328,7 +328,7 @@ do_trans_CU_simple(pTHX_ SV *sv)
 /* utf-8 to latin-1 */
 
 STATIC I32
-do_trans_UC_trivial(pTHX_ SV *sv)
+S_do_trans_UC_trivial(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -360,7 +360,7 @@ do_trans_UC_trivial(pTHX_ SV *sv)
 /* latin-1 to utf-8 */
 
 STATIC I32
-do_trans_CU_trivial(pTHX_ SV *sv)
+S_do_trans_CU_trivial(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -394,7 +394,7 @@ do_trans_CU_trivial(pTHX_ SV *sv)
 }
 
 STATIC I32
-do_trans_UU_complex(pTHX_ SV *sv)
+S_do_trans_UU_complex(pTHX_ SV *sv)
 {
     dTHR;
     U8 *s;
@@ -585,7 +585,7 @@ Perl_do_trans(pTHX_ SV *sv)
     STRLEN len;
 
     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
 
     (void)SvPV(sv, len);
     if (!len)
@@ -594,7 +594,7 @@ Perl_do_trans(pTHX_ SV *sv)
 	(void)SvPV_force(sv, len);
     (void)SvPOK_only(sv);
 
-    DEBUG_t( deb("2.TBL\n"));
+    DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 
     switch (PL_op->op_private & 63) {
     case 0:
@@ -697,6 +697,138 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 	SvTAINTED_on(sv);
 }
 
+UV
+Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
+{
+    STRLEN srclen, len;
+    unsigned char *s = (unsigned char *) SvPV(sv, srclen);
+    UV retnum = 0;
+
+    if (offset < 0)
+	return retnum;
+    if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ 
+	Perl_croak(aTHX_ "Illegal number of bits in vec");
+    offset *= size;	/* turn into bit offset */
+    len = (offset + size + 7) / 8;	/* required number of bytes */
+    if (len > srclen) {
+	if (size <= 8)
+	    retnum = 0;
+	else {
+	    offset >>= 3;	/* turn into byte offset */
+	    if (size == 16) {
+		if (offset >= srclen)
+		    retnum = 0;
+		else
+		    retnum = (UV) s[offset] <<  8;
+	    }
+	    else if (size == 32) {
+		if (offset >= srclen)
+		    retnum = 0;
+		else if (offset + 1 >= srclen)
+		    retnum =
+			((UV) s[offset    ] << 24);
+		else if (offset + 2 >= srclen)
+		    retnum =
+			((UV) s[offset    ] << 24) +
+			((UV) s[offset + 1] << 16);
+		else
+		    retnum =
+			((UV) s[offset    ] << 24) +
+			((UV) s[offset + 1] << 16) +
+			(     s[offset + 2] <<  8);
+	    }
+#ifdef UV_IS_QUAD
+	    else if (size == 64) {
+		dTHR;
+		if (ckWARN(WARN_PORTABLE))
+		    Perl_warner(aTHX_ WARN_PORTABLE,
+				"Bit vector size > 32 non-portable");
+		if (offset >= srclen)
+		    retnum = 0;
+		else if (offset + 1 >= srclen)
+		    retnum =
+			(UV) s[offset     ] << 56;
+		else if (offset + 2 >= srclen)
+		    retnum =
+			((UV) s[offset    ] << 56) +
+			((UV) s[offset + 1] << 48);
+		else if (offset + 3 >= srclen)
+		    retnum =
+			((UV) s[offset    ] << 56) +
+			((UV) s[offset + 1] << 48) +
+			((UV) s[offset + 2] << 40);
+		else if (offset + 4 >= srclen)
+		    retnum =
+			((UV) s[offset    ] << 56) +
+			((UV) s[offset + 1] << 48) +
+			((UV) s[offset + 2] << 40) +
+			((UV) s[offset + 3] << 32);
+		else if (offset + 5 >= srclen)
+		    retnum =
+			((UV) s[offset    ] << 56) +
+			((UV) s[offset + 1] << 48) +
+			((UV) s[offset + 2] << 40) +
+			((UV) s[offset + 3] << 32) +
+			(     s[offset + 4] << 24);
+		else if (offset + 6 >= srclen)
+		    retnum =
+			((UV) s[offset    ] << 56) +
+			((UV) s[offset + 1] << 48) +
+			((UV) s[offset + 2] << 40) +
+			((UV) s[offset + 3] << 32) +
+			((UV) s[offset + 4] << 24) +
+			((UV) s[offset + 5] << 16);
+		else
+		    retnum = 
+			((UV) s[offset    ] << 56) +
+			((UV) s[offset + 1] << 48) +
+			((UV) s[offset + 2] << 40) +
+			((UV) s[offset + 3] << 32) +
+			((UV) s[offset + 4] << 24) +
+			((UV) s[offset + 5] << 16) +
+			(     s[offset + 6] <<  8);
+	    }
+#endif
+	}
+    }
+    else if (size < 8)
+	retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+    else {
+	offset >>= 3;	/* turn into byte offset */
+	if (size == 8)
+	    retnum = s[offset];
+	else if (size == 16)
+	    retnum =
+		((UV) s[offset] <<      8) +
+		      s[offset + 1];
+	else if (size == 32)
+	    retnum =
+		((UV) s[offset    ] << 24) +
+		((UV) s[offset + 1] << 16) +
+		(     s[offset + 2] <<  8) +
+		      s[offset + 3];
+#ifdef UV_IS_QUAD
+	else if (size == 64) {
+	    dTHR;
+	    if (ckWARN(WARN_PORTABLE))
+		Perl_warner(aTHX_ WARN_PORTABLE,
+			    "Bit vector size > 32 non-portable");
+	    retnum =
+		((UV) s[offset    ] << 56) +
+		((UV) s[offset + 1] << 48) +
+		((UV) s[offset + 2] << 40) +
+		((UV) s[offset + 3] << 32) +
+		((UV) s[offset + 4] << 24) +
+		((UV) s[offset + 5] << 16) +
+		(     s[offset + 6] <<  8) +
+		      s[offset + 7];
+	}
+#endif
+    }
+
+    return retnum;
+}
+
 void
 Perl_do_vecset(pTHX_ SV *sv)
 {
@@ -704,7 +836,7 @@ Perl_do_vecset(pTHX_ SV *sv)
     register I32 offset;
     register I32 size;
     register unsigned char *s;
-    register unsigned long lval;
+    register UV lval;
     I32 mask;
     STRLEN targlen;
     STRLEN len;
@@ -712,11 +844,14 @@ Perl_do_vecset(pTHX_ SV *sv)
     if (!targ)
 	return;
     s = (unsigned char*)SvPV_force(targ, targlen);
-    lval = U_L(SvNV(sv));
+    lval = SvUV(sv);
     offset = LvTARGOFF(sv);
     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");
     
-    len = (offset + size + 7) / 8;
+    offset *= size;			/* turn into bit offset */
+    len = (offset + size + 7) / 8;	/* required number of bytes */
     if (len > targlen) {
 	s = (unsigned char*)SvGROW(targ, len + 1);
 	(void)memzero(s + targlen, len - targlen + 1);
@@ -727,25 +862,42 @@ Perl_do_vecset(pTHX_ SV *sv)
 	mask = (1 << size) - 1;
 	size = offset & 7;
 	lval &= mask;
-	offset >>= 3;
+	offset >>= 3;			/* turn into byte offset */
 	s[offset] &= ~(mask << size);
 	s[offset] |= lval << size;
     }
     else {
-	offset >>= 3;
+	offset >>= 3;			/* turn into byte offset */
 	if (size == 8)
-	    s[offset] = lval & 255;
+	    s[offset  ] = lval         & 0xff;
 	else if (size == 16) {
-	    s[offset] = (lval >> 8) & 255;
-	    s[offset+1] = lval & 255;
+	    s[offset  ] = (lval >>  8) & 0xff;
+	    s[offset+1] = lval         & 0xff;
 	}
 	else if (size == 32) {
-	    s[offset] = (lval >> 24) & 255;
-	    s[offset+1] = (lval >> 16) & 255;
-	    s[offset+2] = (lval >> 8) & 255;
-	    s[offset+3] = lval & 255;
+	    s[offset  ] = (lval >> 24) & 0xff;
+	    s[offset+1] = (lval >> 16) & 0xff;
+	    s[offset+2] = (lval >>  8) & 0xff;
+	    s[offset+3] =  lval        & 0xff;
 	}
+#ifdef UV_IS_QUAD
+	else if (size == 64) {
+	    dTHR;
+	    if (ckWARN(WARN_PORTABLE))
+		Perl_warner(aTHX_ 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;
+	}
+#endif
     }
+    SvSETMAGIC(targ);
 }
 
 void
@@ -772,44 +924,45 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
 	HE* entry;
         (void)hv_iterinit(hv);
         /*SUPPRESS 560*/
-        while (entry = hv_iternext(hv))
+        while ((entry = hv_iternext(hv)))
             do_chop(astr,hv_iterval(hv,entry));
         return;
     }
     else if (SvREADONLY(sv))
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
     s = SvPV(sv, len);
     if (len && !SvPOK(sv))
 	s = SvPV_force(sv, len);
-    if (IN_UTF8) {
+    if (DO_UTF8(sv)) {
 	if (s && len) {
 	    char *send = s + len;
 	    char *start = s;
 	    s = send - 1;
 	    while ((*s & 0xc0) == 0x80)
 		--s;
-	    if (UTF8SKIP(s) != send - s)
-		warn("Malformed UTF-8 character");
+	    if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
+		Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
 	    sv_setpvn(astr, s, send - s);
 	    *s = '\0';
 	    SvCUR_set(sv, s - start);
 	    SvNIOK_off(sv);
+	    SvUTF8_on(astr);
 	}
 	else
 	    sv_setpvn(astr, "", 0);
     }
-    else
-    if (s && len) {
+    else if (s && len) {
 	s += --len;
 	sv_setpvn(astr, s, 1);
 	*s = '\0';
 	SvCUR_set(sv, len);
+	SvUTF8_off(sv);
 	SvNIOK_off(sv);
     }
     else
 	sv_setpvn(astr, "", 0);
     SvSETMAGIC(sv);
-} 
+}
 
 I32
 Perl_do_chomp(pTHX_ register SV *sv)
@@ -841,12 +994,12 @@ Perl_do_chomp(pTHX_ register SV *sv)
 	HE* entry;
         (void)hv_iterinit(hv);
         /*SUPPRESS 560*/
-        while (entry = hv_iternext(hv))
+        while ((entry = hv_iternext(hv)))
             count += do_chomp(hv_iterval(hv,entry));
         return count;
     }
     else if (SvREADONLY(sv))
-	croak(PL_no_modify);
+	Perl_croak(aTHX_ PL_no_modify);
     s = SvPV(sv, len);
     if (len && !SvPOKp(sv))
 	s = SvPV_force(sv, len);
@@ -907,6 +1060,13 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
     I32 lensave;
     char *lsave;
     char *rsave;
+    bool left_utf = DO_UTF8(left);
+    bool right_utf = DO_UTF8(right);
+
+    if (left_utf && !right_utf)
+	sv_utf8_upgrade(right);
+    if (!left_utf && right_utf)
+	sv_utf8_upgrade(left);
 
     if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
 	sv_setpvn(sv, "", 0);	/* avoid undef warning on |= and ^= */
@@ -931,6 +1091,69 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
     }
     SvCUR_set(sv, len);
     (void)SvPOK_only(sv);
+    if (left_utf || right_utf) {
+	UV duc, luc, ruc;
+	STRLEN lulen = leftlen;
+	STRLEN rulen = rightlen;
+	STRLEN dulen = 0;
+	I32 ulen;
+
+	if (optype != OP_BIT_AND)
+	    dc = SvGROW(sv, leftlen+rightlen+1);
+
+	switch (optype) {
+	case OP_BIT_AND:
+	    while (lulen && rulen) {
+		luc = utf8_to_uv((U8*)lc, &ulen);
+		lc += ulen;
+		lulen -= ulen;
+		ruc = utf8_to_uv((U8*)rc, &ulen);
+		rc += ulen;
+		rulen -= ulen;
+		duc = luc & ruc;
+		dc = (char*)uv_to_utf8((U8*)dc, duc);
+	    }
+	    dulen = dc - SvPVX(sv);
+	    SvCUR_set(sv, dulen);
+	    break;
+	case OP_BIT_XOR:
+	    while (lulen && rulen) {
+		luc = utf8_to_uv((U8*)lc, &ulen);
+		lc += ulen;
+		lulen -= ulen;
+		ruc = utf8_to_uv((U8*)rc, &ulen);
+		rc += ulen;
+		rulen -= ulen;
+		duc = luc ^ ruc;
+		dc = (char*)uv_to_utf8((U8*)dc, duc);
+	    }
+	    goto mop_up_utf;
+	case OP_BIT_OR:
+	    while (lulen && rulen) {
+		luc = utf8_to_uv((U8*)lc, &ulen);
+		lc += ulen;
+		lulen -= ulen;
+		ruc = utf8_to_uv((U8*)rc, &ulen);
+		rc += ulen;
+		rulen -= ulen;
+		duc = luc | ruc;
+		dc = (char*)uv_to_utf8((U8*)dc, duc);
+	    }
+	  mop_up_utf:
+	    dulen = dc - SvPVX(sv);
+	    SvCUR_set(sv, dulen);
+	    if (rulen)
+		sv_catpvn(sv, rc, rulen);
+	    else if (lulen)
+		sv_catpvn(sv, lc, lulen);
+	    else
+		*SvEND(sv) = '\0';
+	    break;
+	}
+	SvUTF8_on(sv);
+	goto finish;
+    }
+    else
 #ifdef LIBERAL
     if (len >= sizeof(long)*4 &&
 	!((long)dc % sizeof(long)) &&
@@ -1001,11 +1224,12 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 	    break;
 	}
     }
+finish:
     SvTAINT(sv);
 }
 
 OP *
-Perl_do_kv(pTHX_ ARGSproto)
+Perl_do_kv(pTHX)
 {
     djSP;
     HV *hv = (HV*)POPs;
@@ -1069,7 +1293,7 @@ Perl_do_kv(pTHX_ ARGSproto)
     EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
 
     PUTBACK;	/* hv_iternext and hv_iterval might clobber stack_sp */
-    while (entry = hv_iternext(keys)) {
+    while ((entry = hv_iternext(keys))) {
 	SPAGAIN;
 	if (dokeys)
 	    XPUSHs(hv_iterkeysv(entry));	/* won't clobber stack_sp */
@@ -1077,7 +1301,7 @@ Perl_do_kv(pTHX_ ARGSproto)
 	    PUTBACK;
 	    tmpstr = realhv ?
 		     hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
-	    DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu",
+	    DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
 			    (unsigned long)HeHASH(entry),
 			    HvMAX(keys)+1,
 			    (unsigned long)(HeHASH(entry) & HvMAX(keys))));