X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=e86c49fdcf63ab3aac316e0f63656274f4ddbf6b;hb=517e7c645afd88cb6b76e340708d0fff8202d858;hp=b27774af7f9aeb4f08a6aa1d9c6de0493ec8ccd7;hpb=6b8eaf932222db04db65aff99717b9c1dbd0a692;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/utf8.c b/utf8.c
index b27774a..e86c49f 100644
--- a/utf8.c
+++ b/utf8.c
@@ -1,6 +1,6 @@
 /*    utf8.c
  *
- *    Copyright (c) 1998-1999, Larry Wall
+ *    Copyright (c) 1998-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.
@@ -69,7 +69,7 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
 	return d;
     }
 #ifdef HAS_QUAD
-    if (uv < 0x2000000000)
+    if (uv < 0x1000000000LL)
 #endif
     {
 	*d++ =                        0xfe;	/* Can't match U+FEFF! */
@@ -84,6 +84,11 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
 #ifdef HAS_QUAD
     {
 	*d++ =                        0xff;	/* Can't match U+FFFE! */
+	*d++ =                        0x80;	/* 6 Reserved bits */
+	*d++ = (((uv >> 60) & 0x0f) | 0x80);	/* 2 Reserved bits */
+	*d++ = (((uv >> 54) & 0x3f) | 0x80);
+	*d++ = (((uv >> 48) & 0x3f) | 0x80);
+	*d++ = (((uv >> 42) & 0x3f) | 0x80);
 	*d++ = (((uv >> 36) & 0x3f) | 0x80);
 	*d++ = (((uv >> 30) & 0x3f) | 0x80);
 	*d++ = (((uv >> 24) & 0x3f) | 0x80);
@@ -96,6 +101,63 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv)
 #endif
 }
 
+/* Tests if some arbitrary number of bytes begins in a valid UTF-8 character.
+ * The actual number of bytes in the UTF-8 character will be returned if it
+ * is valid, otherwise 0. */
+int
+Perl_is_utf8_char(pTHX_ U8 *s)
+{
+    U8 u = *s;
+    int slen, len;
+
+    if (!(u & 0x80))
+	return 1;
+
+    if (!(u & 0x40))
+	return 0;
+
+    if      (!(u & 0x20))	{ len = 2; }
+    else if (!(u & 0x10))	{ len = 3; }
+    else if (!(u & 0x08))	{ len = 4; }
+    else if (!(u & 0x04))	{ len = 5; }
+    else if (!(u & 0x02))	{ len = 6; }
+    else if (!(u & 0x01))	{ len = 7; }
+    else 			{ len = 13; } /* whoa! */
+
+    slen = len - 1;
+    s++;
+    while (slen--) {
+	if ((*s & 0xc0) != 0x80)
+	    return 0;
+	s++;
+    }
+    return len;
+}
+
+/*
+=for apidoc Am|bool_utf8_string|U8 *s|STRLEN len
+
+Returns true if first C<len> bytes of the given string form valid a UTF8
+string, false otherwise.
+
+=cut
+*/
+
+bool 
+Perl_is_utf8_string(pTHX_ U8 *s, STRLEN len)
+{
+    U8* x=s;
+    U8* send=s+len;
+    int c;
+    while (x < send) {
+        c = is_utf8_char(x);
+        x += c;
+        if (!c || x > send)
+            return 0;
+    }
+    return 1;
+}
+
 UV
 Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen)
 {
@@ -120,8 +182,8 @@ Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen)
     else if (!(uv & 0x08))	{ len = 4; uv &= 0x07; }
     else if (!(uv & 0x04))	{ len = 5; uv &= 0x03; }
     else if (!(uv & 0x02))	{ len = 6; uv &= 0x01; }
-    else if (!(uv & 0x01))	{ len = 7; uv &= 0x00; }
-    else 			  len = 8;	/* whoa! */
+    else if (!(uv & 0x01))	{ len = 7;  uv = 0; }
+    else 			{ len = 13; uv = 0; } /* whoa! */
 
     if (retlen)
 	*retlen = len;
@@ -184,19 +246,100 @@ Perl_utf8_hop(pTHX_ U8 *s, I32 off)
     return s;
 }
 
-/* XXX NOTHING CALLS THE FOLLOWING TWO ROUTINES YET!!! */
 /*
- * Convert native or reversed UTF-16 to UTF-8.
+=for apidoc Am|U8 *|utf8_to_bytes|U8 *s|STRLEN len
+
+Converts a string C<s> of length C<len> from UTF8 into ASCII encoding.
+Unlike C<bytes_to_utf8>, this over-writes the original string.
+Returns zero on failure after converting as much as possible.
+
+=cut
+*/
+
+U8 *
+Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN len)
+{
+    dTHR;
+    U8 *send;
+    U8 *d;
+    U8 *save;
+
+    send = s + len;
+    d = save = s;
+    while (s < send) {
+        if (*s < 0x80)
+            *d++ = *s++;
+        else {
+            I32 ulen;
+            UV uv = utf8_to_uv(s, &ulen);
+            if (uv > 255) {
+                *d = '\0';
+                return 0;
+            }
+            s += ulen;
+            *d++ = (U8)uv;
+        }
+    }
+    *d = '\0';
+    return save;
+}
+
+/*
+=for apidoc Am|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
+
+Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
+Returns a pointer to the newly-created string, and sets C<len> to
+reflect the new length.
+
+=cut
+*/
+
+U8*
+Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
+{
+    dTHR;
+    U8 *send;
+    U8 *d;
+    U8 *dst;
+    send = s + (*len);
+
+    Newz(801, d, (*len) * 2 + 1, U8);
+    dst = d;
+
+    while (s < send) {
+        if (*s < 0x80)
+            *d++ = *s++;
+        else {
+            UV uv = *s++;
+            *d++ = (( uv >>  6)         | 0xc0);
+            *d++ = (( uv        & 0x3f) | 0x80);
+        }
+    }
+    *d = '\0';
+    *len = d-dst;
+    return dst;
+}
+
+/*
+ * Convert native (big-endian) or reversed (little-endian) UTF-16 to UTF-8.
  *
  * Destination must be pre-extended to 3/2 source.  Do not use in-place.
  * We optimize for native, for obvious reasons. */
 
 U8*
-Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen)
+Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 {
-    U16* pend = p + bytelen / 2;
+    U8* pend;
+    U8* dstart = d;
+
+    if (bytelen & 1)
+	Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen");
+
+    pend = p + bytelen;
+
     while (p < pend) {
-	UV uv = *p++;
+	UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
+	p += 2;
 	if (uv < 0x80) {
 	    *d++ = uv;
 	    continue;
@@ -208,13 +351,9 @@ Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen)
 	}
 	if (uv >= 0xd800 && uv < 0xdbff) {	/* surrogates */
             dTHR;
-	    int low = *p++;
-	    if (low < 0xdc00 || low >= 0xdfff) {
-		if (ckWARN_d(WARN_UTF8))     
-	    	    Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-16 surrogate");
-		p--;
-		uv = 0xfffd;
-	    }
+	    UV low = *p++;
+	    if (low < 0xdc00 || low >= 0xdfff)
+		Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
 	    uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
 	}
 	if (uv < 0x10000) {
@@ -231,13 +370,14 @@ Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen)
 	    continue;
 	}
     }
+    *newlen = d - dstart;
     return d;
 }
 
 /* Note: this one is slightly destructive of the source. */
 
 U8*
-Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen)
+Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, I32 bytelen, I32 *newlen)
 {
     U8* s = (U8*)p;
     U8* send = s + bytelen;
@@ -247,7 +387,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen)
 	s[1] = tmp;
 	s += 2;
     }
-    return utf16_to_utf8(p, d, bytelen);
+    return utf16_to_utf8(p, d, bytelen, newlen);
 }
 
 /* for now these are all defined (inefficiently) in terms of the utf8 versions */
@@ -255,7 +395,7 @@ Perl_utf16_to_utf8_reversed(pTHX_ U16* p, U8* d, I32 bytelen)
 bool
 Perl_is_uni_alnum(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alnum(tmpbuf);
 }
@@ -263,7 +403,7 @@ Perl_is_uni_alnum(pTHX_ U32 c)
 bool
 Perl_is_uni_alnumc(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alnumc(tmpbuf);
 }
@@ -271,7 +411,7 @@ Perl_is_uni_alnumc(pTHX_ U32 c)
 bool
 Perl_is_uni_idfirst(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_idfirst(tmpbuf);
 }
@@ -279,7 +419,7 @@ Perl_is_uni_idfirst(pTHX_ U32 c)
 bool
 Perl_is_uni_alpha(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_alpha(tmpbuf);
 }
@@ -287,7 +427,7 @@ Perl_is_uni_alpha(pTHX_ U32 c)
 bool
 Perl_is_uni_ascii(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_ascii(tmpbuf);
 }
@@ -295,7 +435,7 @@ Perl_is_uni_ascii(pTHX_ U32 c)
 bool
 Perl_is_uni_space(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_space(tmpbuf);
 }
@@ -303,7 +443,7 @@ Perl_is_uni_space(pTHX_ U32 c)
 bool
 Perl_is_uni_digit(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_digit(tmpbuf);
 }
@@ -311,7 +451,7 @@ Perl_is_uni_digit(pTHX_ U32 c)
 bool
 Perl_is_uni_upper(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_upper(tmpbuf);
 }
@@ -319,7 +459,7 @@ Perl_is_uni_upper(pTHX_ U32 c)
 bool
 Perl_is_uni_lower(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_lower(tmpbuf);
 }
@@ -327,7 +467,7 @@ Perl_is_uni_lower(pTHX_ U32 c)
 bool
 Perl_is_uni_cntrl(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_cntrl(tmpbuf);
 }
@@ -335,7 +475,7 @@ Perl_is_uni_cntrl(pTHX_ U32 c)
 bool
 Perl_is_uni_graph(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_graph(tmpbuf);
 }
@@ -343,7 +483,7 @@ Perl_is_uni_graph(pTHX_ U32 c)
 bool
 Perl_is_uni_print(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_print(tmpbuf);
 }
@@ -351,7 +491,7 @@ Perl_is_uni_print(pTHX_ U32 c)
 bool
 Perl_is_uni_punct(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_punct(tmpbuf);
 }
@@ -359,7 +499,7 @@ Perl_is_uni_punct(pTHX_ U32 c)
 bool
 Perl_is_uni_xdigit(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return is_utf8_xdigit(tmpbuf);
 }
@@ -367,7 +507,7 @@ Perl_is_uni_xdigit(pTHX_ U32 c)
 U32
 Perl_to_uni_upper(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_upper(tmpbuf);
 }
@@ -375,7 +515,7 @@ Perl_to_uni_upper(pTHX_ U32 c)
 U32
 Perl_to_uni_title(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_title(tmpbuf);
 }
@@ -383,7 +523,7 @@ Perl_to_uni_title(pTHX_ U32 c)
 U32
 Perl_to_uni_lower(pTHX_ U32 c)
 {
-    U8 tmpbuf[10];
+    U8 tmpbuf[UTF8_MAXLEN];
     uv_to_utf8(tmpbuf, (UV)c);
     return to_utf8_lower(tmpbuf);
 }
@@ -495,6 +635,8 @@ Perl_to_uni_lower_lc(pTHX_ U32 c)
 bool
 Perl_is_utf8_alnum(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_alnum)
 	PL_utf8_alnum = swash_init("utf8", "IsAlnum", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_alnum, p);
@@ -510,6 +652,8 @@ Perl_is_utf8_alnum(pTHX_ U8 *p)
 bool
 Perl_is_utf8_alnumc(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_alnum)
 	PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_alnum, p);
@@ -531,6 +675,8 @@ Perl_is_utf8_idfirst(pTHX_ U8 *p)
 bool
 Perl_is_utf8_alpha(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_alpha)
 	PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_alpha, p);
@@ -539,6 +685,8 @@ Perl_is_utf8_alpha(pTHX_ U8 *p)
 bool
 Perl_is_utf8_ascii(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_ascii)
 	PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_ascii, p);
@@ -547,6 +695,8 @@ Perl_is_utf8_ascii(pTHX_ U8 *p)
 bool
 Perl_is_utf8_space(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_space)
 	PL_utf8_space = swash_init("utf8", "IsSpace", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_space, p);
@@ -555,6 +705,8 @@ Perl_is_utf8_space(pTHX_ U8 *p)
 bool
 Perl_is_utf8_digit(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_digit)
 	PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_digit, p);
@@ -563,6 +715,8 @@ Perl_is_utf8_digit(pTHX_ U8 *p)
 bool
 Perl_is_utf8_upper(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_upper)
 	PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_upper, p);
@@ -571,6 +725,8 @@ Perl_is_utf8_upper(pTHX_ U8 *p)
 bool
 Perl_is_utf8_lower(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_lower)
 	PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_lower, p);
@@ -579,6 +735,8 @@ Perl_is_utf8_lower(pTHX_ U8 *p)
 bool
 Perl_is_utf8_cntrl(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_cntrl)
 	PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_cntrl, p);
@@ -587,6 +745,8 @@ Perl_is_utf8_cntrl(pTHX_ U8 *p)
 bool
 Perl_is_utf8_graph(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_graph)
 	PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_graph, p);
@@ -595,6 +755,8 @@ Perl_is_utf8_graph(pTHX_ U8 *p)
 bool
 Perl_is_utf8_print(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_print)
 	PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_print, p);
@@ -603,6 +765,8 @@ Perl_is_utf8_print(pTHX_ U8 *p)
 bool
 Perl_is_utf8_punct(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_punct)
 	PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_punct, p);
@@ -611,6 +775,8 @@ Perl_is_utf8_punct(pTHX_ U8 *p)
 bool
 Perl_is_utf8_xdigit(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_xdigit)
 	PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_xdigit, p);
@@ -619,6 +785,8 @@ Perl_is_utf8_xdigit(pTHX_ U8 *p)
 bool
 Perl_is_utf8_mark(pTHX_ U8 *p)
 {
+    if (!is_utf8_char(p))
+	return FALSE;
     if (!PL_utf8_mark)
 	PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0);
     return swash_fetch(PL_utf8_mark, p);
@@ -665,6 +833,13 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
     SV* retval;
     char tmpbuf[256];
     dSP;    
+
+    if (!gv_stashpv(pkg, 0)) {	/* demand load utf8 */
+	ENTER;
+	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
+	LEAVE;
+    }
+    SPAGAIN;
     PUSHSTACKi(PERLSI_MAGIC);
     PUSHMARK(SP);
     EXTEND(SP,5);
@@ -718,7 +893,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
 
     if (hv == PL_last_swash_hv &&
 	klen == PL_last_swash_klen &&
-	(!klen || memEQ(ptr,PL_last_swash_key,klen)) )
+	(!klen || memEQ((char *)ptr,(char *)PL_last_swash_key,klen)) )
     {
 	tmps = PL_last_swash_tmps;
 	slen = PL_last_swash_slen;