X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utf8.c;h=f900724ab05df4eb6643d400218a5880ef3dcff2;hb=1bb908c3a4ad348fff25b9046b4be74565cde673;hp=b682cf65caabf5c7f3766bf7e50ef6d93db5d510;hpb=3568d8383f3d0b22eb07927391114af2a91b06ed;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/utf8.c b/utf8.c
index b682cf6..f900724 100644
--- a/utf8.c
+++ b/utf8.c
@@ -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)
 {
@@ -1198,37 +1180,98 @@ Perl_is_utf8_mark(pTHX_ U8 *p)
     return swash_fetch(PL_utf8_mark, p, TRUE);
 }
 
+/*
+=for apidoc A|UV|to_utf8_case|U8 *p|U8* ustrp|STRLEN *lenp|SV **swash|char *normal|char *special
+
+The "p" contains the pointer to the UTF-8 string encoding
+the character that is being converted.
+
+The "ustrp" is a pointer to the character buffer to put the
+conversion result to.  The "lenp" is a pointer to the length
+of the result.
+
+The "swash" is a pointer to the swash to use.
+
+The "normal" is a string like "ToLower" which means the swash
+$utf8::ToLower, which is stored in lib/unicore/To/Lower.pl,
+and loaded by SWASHGET, using lib/utf8_heavy.pl.
+
+The "special" is a string like "utf8::ToSpecLower", which means
+the hash %utf8::ToSpecLower, which is stored in the same file,
+lib/unicore/To/Lower.pl, and also loaded by SWASHGET.  The access
+to the hash is by Perl_to_utf8_case().
+
+=cut
+ */
+
 UV
-Perl_to_utf8_upper(pTHX_ U8 *p)
+Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special)
 {
     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, TRUE);
-    return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
+    if (!*swashp)
+        *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
+    uv = swash_fetch(*swashp, p, TRUE);
+    if (uv)
+	 uv = UNI_TO_NATIVE(uv);
+    else {
+	 HV *hv;
+	 SV *keysv;
+	 HE *he;
+
+	 uv = utf8_to_uvchr(p, 0);
+	 if (uv <= 0xff)
+	     uv = NATIVE_TO_UTF(uv);
+
+	 if ((hv    = get_hv(special, FALSE)) &&
+	     (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv))) &&
+	     (he    = hv_fetch_ent(hv, keysv, FALSE, 0))) {
+	      SV *val = HeVAL(he);
+	      char *s = SvPV(val, *lenp);
+	      U8 c = *(U8*)s;
+	      if (*lenp > 1 || UNI_IS_INVARIANT(c))
+		   Copy(s, ustrp, *lenp, U8);
+	      else {
+		   c = UTF_TO_NATIVE(c);
+		   /* something in the 0x80..0xFF range */
+		   ustrp[0] = UTF8_EIGHT_BIT_HI(c);
+		   ustrp[1] = UTF8_EIGHT_BIT_LO(c);
+		   *lenp = 2;
+	      }
+	      return 0;
+	 }
+    }
+    *lenp = UNISKIP(uv);
+    uvuni_to_utf8(ustrp, uv);
+    return uv;
 }
 
 UV
-Perl_to_utf8_title(pTHX_ U8 *p)
+Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
 {
-    UV uv;
+    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+                             &PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
+}
 
-    if (!PL_utf8_totitle)
-	PL_utf8_totitle = swash_init("utf8", "ToTitle", &PL_sv_undef, 4, 0);
-    uv = swash_fetch(PL_utf8_totitle, p, TRUE);
-    return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
+UV
+Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
+{
+    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+                             &PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
 }
 
 UV
-Perl_to_utf8_lower(pTHX_ U8 *p)
+Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
 {
-    UV uv;
+    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+                             &PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
+}
 
-    if (!PL_utf8_tolower)
-	PL_utf8_tolower = swash_init("utf8", "ToLower", &PL_sv_undef, 4, 0);
-    uv = swash_fetch(PL_utf8_tolower, p, TRUE);
-    return uv ? UNI_TO_NATIVE(uv) : utf8_to_uvchr(p,0);
+UV
+Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
+{
+    return Perl_to_utf8_case(aTHX_ p, ustrp, lenp,
+                             &PL_utf8_tofold, "ToFold", "utf8::ToSpecFold");
 }
 
 /* a "swash" is a swatch hash */
@@ -1240,10 +1283,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 +1311,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,6 +1333,12 @@ 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, bool do_utf8)
 {
@@ -1289,7 +1347,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
     U32 off;
     STRLEN slen;
     STRLEN needents;
-    U8 *tmps;
+    U8 *tmps = NULL;
     U32 bit;
     SV *retval;
     U8 tmputf8[2];
@@ -1350,6 +1408,7 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
 	       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();
@@ -1362,10 +1421,14 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
 				     (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;
@@ -1455,4 +1518,31 @@ Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
     return UNI_TO_NATIVE(uv);
 }
 
+char *
+Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
+{
+    int truncated = 0;
+    char *s, *e;
+
+    sv_setpvn(dsv, "", 0);
+    for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
+	 UV u;
+	 if (pvlim && SvCUR(dsv) >= pvlim) {
+	      truncated++;
+	      break;
+	 }
+	 u = utf8_to_uvchr((U8*)s, 0);
+	 Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
+    }
+    if (truncated)
+	 sv_catpvn(dsv, "...", 3);
+    
+    return SvPVX(dsv);
+}
 
+char *
+Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags)
+{
+  return Perl_pv_uni_display(aTHX_ dsv, (U8*)SvPVX(ssv), SvCUR(ssv),
+			     pvlim, flags);
+}