X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=0c094697e751f7a4d7e27065246905c8717f18db;hb=a5d0b98deea758380063fe2b6a93bf49a9fff7e5;hp=785047e673f8f07155c20b8d70212e3bf1682195;hpb=37607a96501d29b9cd8e4976a682c9ac460e70db;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/utf8.c b/utf8.c
index 785047e..0c09469 100644
--- a/utf8.c
+++ b/utf8.c
@@ -163,14 +163,14 @@ Perl_is_utf8_char(pTHX_ U8 *s)
 
     slen = len - 1;
     s++;
-    /* The initial value is dubious */
+    u &= UTF_START_MASK(len);
     uv  = u;
     ouv = uv;
     while (slen--) {
 	if (!UTF8_IS_CONTINUATION(*s))
 	    return 0;
 	uv = UTF8_ACCUMULATE(uv, *s);
-	if (uv < ouv)
+	if (uv < ouv) 
 	    return 0;
 	ouv = uv;
 	s++;
@@ -243,7 +243,7 @@ Most code should use utf8_to_uvchr() rather than call this directly.
 UV
 Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 {
-    UV uv = *s, ouv;
+    UV uv = *s, ouv = 0;
     STRLEN len = 1;
     bool dowarn = ckWARN_d(WARN_UTF8);
     STRLEN expectlen = 0;
@@ -428,7 +428,7 @@ malformed:
 
 	    if (PL_op)
 		Perl_warner(aTHX_ WARN_UTF8,
-			    "%s in %s", s,  PL_op_desc[PL_op->op_type]);
+			    "%s in %s", s,  OP_DESC(PL_op));
 	    else
 		Perl_warner(aTHX_ WARN_UTF8, "%s", s);
 	}
@@ -507,7 +507,7 @@ Perl_utf8_length(pTHX_ U8 *s, U8 *e)
 	U8 t = UTF8SKIP(s);
 
 	if (e - s < t)
-	    Perl_croak(aTHX_ "panic: utf8_length: s=%p (%02X) e=%p l=%d - unaligned end",s,*s,e,t);
+	    Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
 	s += t;
 	len++;
     }
@@ -902,33 +902,33 @@ Perl_is_uni_punct(pTHX_ U32 c)
 bool
 Perl_is_uni_xdigit(pTHX_ U32 c)
 {
-    U8 tmpbuf[UTF8_MAXLEN+1];
+    U8 tmpbuf[UTF8_MAXLEN*2+1];
     uvchr_to_utf8(tmpbuf, (UV)c);
     return is_utf8_xdigit(tmpbuf);
 }
 
 U32
-Perl_to_uni_upper(pTHX_ U32 c)
+Perl_to_uni_upper(pTHX_ U32 c, U8* p, STRLEN *lenp)
 {
-    U8 tmpbuf[UTF8_MAXLEN+1];
+    U8 tmpbuf[UTF8_MAXLEN*2+1];
     uvchr_to_utf8(tmpbuf, (UV)c);
-    return to_utf8_upper(tmpbuf);
+    return to_utf8_upper(tmpbuf, p, lenp);
 }
 
 U32
-Perl_to_uni_title(pTHX_ U32 c)
+Perl_to_uni_title(pTHX_ U32 c, U8* p, STRLEN *lenp)
 {
-    U8 tmpbuf[UTF8_MAXLEN+1];
+    U8 tmpbuf[UTF8_MAXLEN*2+1];
     uvchr_to_utf8(tmpbuf, (UV)c);
-    return to_utf8_title(tmpbuf);
+    return to_utf8_title(tmpbuf, p, lenp);
 }
 
 U32
-Perl_to_uni_lower(pTHX_ U32 c)
+Perl_to_uni_lower(pTHX_ U32 c, U8* p, STRLEN *lenp)
 {
     U8 tmpbuf[UTF8_MAXLEN+1];
     uvchr_to_utf8(tmpbuf, (UV)c);
-    return to_utf8_lower(tmpbuf);
+    return to_utf8_lower(tmpbuf, p, lenp);
 }
 
 /* for now these all assume no locale info available for Unicode > 255 */
@@ -1017,24 +1017,6 @@ Perl_is_uni_xdigit_lc(pTHX_ U32 c)
     return is_uni_xdigit(c);	/* XXX no locale support yet */
 }
 
-U32
-Perl_to_uni_upper_lc(pTHX_ U32 c)
-{
-    return to_uni_upper(c);	/* XXX no locale support yet */
-}
-
-U32
-Perl_to_uni_title_lc(pTHX_ U32 c)
-{
-    return to_uni_title(c);	/* XXX no locale support yet */
-}
-
-U32
-Perl_to_uni_lower_lc(pTHX_ U32 c)
-{
-    return to_uni_lower(c);	/* XXX no locale support yet */
-}
-
 bool
 Perl_is_utf8_alnum(pTHX_ U8 *p)
 {
@@ -1045,13 +1027,13 @@ Perl_is_utf8_alnum(pTHX_ U8 *p)
 	 * descendant of isalnum(3), in other words, it doesn't
 	 * contain the '_'. --jhi */
 	PL_utf8_alnum = swash_init("utf8", "IsWord", &PL_sv_undef, 0, 0);
-    return swash_fetch(PL_utf8_alnum, p);
+    return swash_fetch(PL_utf8_alnum, p, TRUE);
 /*    return *p == '_' || is_utf8_alpha(p) || is_utf8_digit(p); */
 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
     if (!PL_utf8_alnum)
 	PL_utf8_alnum = swash_init("utf8", "",
 	    sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
-    return swash_fetch(PL_utf8_alnum, p);
+    return swash_fetch(PL_utf8_alnum, p, TRUE);
 #endif
 }
 
@@ -1062,13 +1044,13 @@ Perl_is_utf8_alnumc(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_alnum, p, TRUE);
 /*    return is_utf8_alpha(p) || is_utf8_digit(p); */
 #ifdef SURPRISINGLY_SLOWER  /* probably because alpha is usually true */
     if (!PL_utf8_alnum)
 	PL_utf8_alnum = swash_init("utf8", "",
 	    sv_2mortal(newSVpv("+utf8::IsAlpha\n+utf8::IsDigit\n005F\n",0)), 0, 0);
-    return swash_fetch(PL_utf8_alnum, p);
+    return swash_fetch(PL_utf8_alnum, p, TRUE);
 #endif
 }
 
@@ -1085,7 +1067,7 @@ Perl_is_utf8_alpha(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_alpha, p, TRUE);
 }
 
 bool
@@ -1095,7 +1077,7 @@ Perl_is_utf8_ascii(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_ascii, p, TRUE);
 }
 
 bool
@@ -1105,7 +1087,7 @@ Perl_is_utf8_space(pTHX_ U8 *p)
 	return FALSE;
     if (!PL_utf8_space)
 	PL_utf8_space = swash_init("utf8", "IsSpacePerl", &PL_sv_undef, 0, 0);
-    return swash_fetch(PL_utf8_space, p);
+    return swash_fetch(PL_utf8_space, p, TRUE);
 }
 
 bool
@@ -1115,7 +1097,7 @@ Perl_is_utf8_digit(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_digit, p, TRUE);
 }
 
 bool
@@ -1125,7 +1107,7 @@ Perl_is_utf8_upper(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_upper, p, TRUE);
 }
 
 bool
@@ -1135,7 +1117,7 @@ Perl_is_utf8_lower(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_lower, p, TRUE);
 }
 
 bool
@@ -1145,7 +1127,7 @@ Perl_is_utf8_cntrl(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_cntrl, p, TRUE);
 }
 
 bool
@@ -1155,7 +1137,7 @@ Perl_is_utf8_graph(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_graph, p, TRUE);
 }
 
 bool
@@ -1165,7 +1147,7 @@ Perl_is_utf8_print(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_print, p, TRUE);
 }
 
 bool
@@ -1175,7 +1157,7 @@ Perl_is_utf8_punct(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_punct, p, TRUE);
 }
 
 bool
@@ -1185,7 +1167,7 @@ Perl_is_utf8_xdigit(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_xdigit, p, TRUE);
 }
 
 bool
@@ -1195,40 +1177,49 @@ Perl_is_utf8_mark(pTHX_ U8 *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);
+    return swash_fetch(PL_utf8_mark, p, TRUE);
 }
 
 UV
-Perl_to_utf8_upper(pTHX_ U8 *p)
+Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
 {
     UV uv;
 
     if (!PL_utf8_toupper)
 	PL_utf8_toupper = swash_init("utf8", "ToUpper", &PL_sv_undef, 4, 0);
-    uv = swash_fetch(PL_utf8_toupper, p);
-    return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
+    uv = swash_fetch(PL_utf8_toupper, p, TRUE);
+    uv = uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p, 0);
+    *lenp = UNISKIP(uv);
+    uvuni_to_utf8(ustrp, uv);
+    return uv;
 }
 
 UV
-Perl_to_utf8_title(pTHX_ U8 *p)
+Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
 {
     UV uv;
 
     if (!PL_utf8_totitle)
 	PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
-    uv = swash_fetch(PL_utf8_totitle, p);
-    return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
+    uv = swash_fetch(PL_utf8_totitle, p, TRUE);
+    uv = uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p, 0);
+    *lenp = UNISKIP(uv);
+    uvuni_to_utf8(ustrp, uv);
+    return uv;
 }
 
 UV
-Perl_to_utf8_lower(pTHX_ U8 *p)
+Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
 {
     UV uv;
 
     if (!PL_utf8_tolower)
 	PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
-    uv = swash_fetch(PL_utf8_tolower, p);
-    return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
+    uv = swash_fetch(PL_utf8_tolower, p, TRUE);
+    uv = uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p, 0);
+    *lenp = UNISKIP(uv);
+    uvuni_to_utf8(ustrp, uv);
+    return uv;
 }
 
 /* a "swash" is a swatch hash */
@@ -1240,10 +1231,15 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
     SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
     dSP;
     HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
+    SV* errsv_save;
 
     if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {	/* demand load utf8 */
 	ENTER;
+	errsv_save = newSVsv(ERRSV);
 	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpv(pkg,0), Nullsv);
+	if (!SvTRUE(ERRSV))
+	    sv_setsv(ERRSV, errsv_save);
+	SvREFCNT_dec(errsv_save);
 	LEAVE;
     }
     SPAGAIN;
@@ -1263,10 +1259,14 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
     if (PL_curcop == &PL_compiling)
 	/* XXX ought to be handled by lex_start */
 	sv_setpv(tokenbufsv, PL_tokenbuf);
+    errsv_save = newSVsv(ERRSV);
     if (call_method("SWASHNEW", G_SCALAR))
 	retval = newSVsv(*PL_stack_sp--);
     else
 	retval = &PL_sv_undef;
+    if (!SvTRUE(ERRSV))
+	sv_setsv(ERRSV, errsv_save);
+    SvREFCNT_dec(errsv_save);
     LEAVE;
     POPSTACK;
     if (PL_curcop == &PL_compiling) {
@@ -1281,22 +1281,38 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
     return retval;
 }
 
+
+/* This API is wrong for special case conversions since we may need to
+ * return several Unicode characters for a single Unicode character
+ * (see lib/unicore/SpecCase.txt) The SWASHGET in lib/utf8_heavy.pl is
+ * the lower-level routine, and it is similarly broken for returning
+ * multiple values.  --jhi */
 UV
-Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
+Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
 {
     HV* hv = (HV*)SvRV(sv);
-    /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
-       then the "swatch" is a vec() for al the chars which start
-       with 0xAA..0xYY
-       So the key in the hash is length of encoded char -1
-     */
-    U32 klen = UTF8SKIP(ptr) - 1;
-    U32 off = ptr[klen];
+    U32 klen;
+    U32 off;
     STRLEN slen;
     STRLEN needents;
     U8 *tmps;
     U32 bit;
     SV *retval;
+    U8 tmputf8[2];
+    UV c = NATIVE_TO_ASCII(*ptr);
+
+    if (!do_utf8 && !UNI_IS_INVARIANT(c)) {
+        tmputf8[0] = UTF8_EIGHT_BIT_HI(c);
+        tmputf8[1] = UTF8_EIGHT_BIT_LO(c);
+        ptr = tmputf8;
+    }
+    /* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
+     * then the "swatch" is a vec() for al the chars which start
+     * with 0xAA..0xYY
+     * So the key in the hash (klen) is length of encoded char -1
+     */
+    klen = UTF8SKIP(ptr) - 1;
+    off  = ptr[klen];
 
     if (klen == 0)
      {
@@ -1322,9 +1338,9 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
      * NB: this code assumes that swatches are never modified, once generated!
      */
 
-    if (hv == PL_last_swash_hv &&
+    if (hv   == PL_last_swash_hv &&
 	klen == PL_last_swash_klen &&
-	(!klen || memEQ((char *)ptr,(char *)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;
@@ -1340,6 +1356,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
 	       Unicode tables, not a native character number.
 	     */
 	    UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, NULL, 0);
+	    SV *errsv_save;
 	    ENTER;
 	    SAVETMPS;
 	    save_re_context();
@@ -1348,13 +1365,18 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr)
 	    EXTEND(SP,3);
 	    PUSHs((SV*)sv);
 	    /* On EBCDIC & ~(0xA0-1) isn't a useful thing to do */
-	    PUSHs(sv_2mortal(newSViv((klen) ? (code_point & ~(needents - 1)) : 0)));
+	    PUSHs(sv_2mortal(newSViv((klen) ?
+				     (code_point & ~(needents - 1)) : 0)));
 	    PUSHs(sv_2mortal(newSViv(needents)));
 	    PUTBACK;
+	    errsv_save = newSVsv(ERRSV);
 	    if (call_method("SWASHGET", G_SCALAR))
 		retval = newSVsv(*PL_stack_sp--);
 	    else
 		retval = &PL_sv_undef;
+	    if (!SvTRUE(ERRSV))
+		sv_setsv(ERRSV, errsv_save);
+	    SvREFCNT_dec(errsv_save);
 	    POPSTACK;
 	    FREETMPS;
 	    LEAVE;