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++;
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)
{
* 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
}
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
}
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
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
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
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
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
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
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
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
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
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
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
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 */
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)
+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)
{
* 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;
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();
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff