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;
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);
}
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++;
}
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 */
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)
{
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 */
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;
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) {
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)
{
U32 off;
STRLEN slen;
STRLEN needents;
- U8 *tmps;
+ U8 *tmps = NULL;
U32 bit;
SV *retval;
U8 tmputf8[2];
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();
(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;
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);
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff