#include "perl.h"
#ifndef EBCDIC
-/* Separate prototypes needed because in ASCII systems these
+/* Separate prototypes needed because in ASCII systems these are
* usually macros but they still are compiled as code, too. */
PERL_CALLCONV UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags);
PERL_CALLCONV U8* Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv);
static const char unees[] =
"Malformed UTF-8 character (unexpected end of string)";
-/*
+/*
=head1 Unicode Support
This file contains various utility functions for manipulating UTF8-encoded
/*
=for apidoc is_ascii_string
-Returns true if first C<len> bytes of the given string are ASCII (i.e. none
-of them even raise the question of UTF-8-ness).
+Returns true if the first C<len> bytes of the given string are the same whether
+or not the string is encoded in UTF-8 (or UTF-EBCDIC on EBCDIC machines). That
+is, if they are invariant. On ASCII-ish machines, only ASCII characters
+fit this definition, hence the function's name.
See also is_utf8_string(), is_utf8_string_loclen(), and is_utf8_string_loc().
if (!UTF8_IS_CONTINUATION(*s))
return 0;
uv = UTF8_ACCUMULATE(uv, *s);
- if (uv < ouv)
+ if (uv < ouv)
return 0;
ouv = uv;
s++;
const UV startbyte = *s;
STRLEN expectlen = 0;
U32 warning = 0;
+ SV* sv;
PERL_ARGS_ASSERT_UTF8N_TO_UVUNI;
-/* This list is a superset of the UTF8_ALLOW_XXX. */
+/* This list is a superset of the UTF8_ALLOW_XXX. BUT it isn't, eg SUPER missing XXX */
#define UTF8_WARN_EMPTY 1
#define UTF8_WARN_CONTINUATION 2
}
if (dowarn) {
- SV* const sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
+ if (warning == UTF8_WARN_FFFF) {
+ sv = newSVpvs_flags("Unicode non-character ", SVs_TEMP);
+ Perl_sv_catpvf(aTHX_ sv, "0x%04"UVxf" is illegal for interchange", uv);
+ }
+ else {
+ sv = newSVpvs_flags("Malformed UTF-8 character ", SVs_TEMP);
+
+ switch (warning) {
+ case 0: /* Intentionally empty. */ break;
+ case UTF8_WARN_EMPTY:
+ sv_catpvs(sv, "(empty string)");
+ break;
+ case UTF8_WARN_CONTINUATION:
+ Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
+ break;
+ case UTF8_WARN_NON_CONTINUATION:
+ if (s == s0)
+ Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
+ (UV)s[1], startbyte);
+ else {
+ const int len = (int)(s-s0);
+ Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
+ (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
+ }
- switch (warning) {
- case 0: /* Intentionally empty. */ break;
- case UTF8_WARN_EMPTY:
- sv_catpvs(sv, "(empty string)");
- break;
- case UTF8_WARN_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
- break;
- case UTF8_WARN_NON_CONTINUATION:
- if (s == s0)
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", immediately after start byte 0x%02"UVxf")",
- (UV)s[1], startbyte);
- else {
- const int len = (int)(s-s0);
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf", %d byte%s after start byte 0x%02"UVxf", expected %d bytes)",
- (UV)s[1], len, len > 1 ? "s" : "", startbyte, (int)expectlen);
+ break;
+ case UTF8_WARN_FE_FF:
+ Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
+ break;
+ case UTF8_WARN_SHORT:
+ Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
+ (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
+ expectlen = curlen; /* distance for caller to skip */
+ break;
+ case UTF8_WARN_OVERFLOW:
+ Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
+ ouv, *s, startbyte);
+ break;
+ case UTF8_WARN_SURROGATE:
+ Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
+ break;
+ case UTF8_WARN_LONG:
+ Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
+ (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
+ break;
+ default:
+ sv_catpvs(sv, "(unknown reason)");
+ break;
}
-
- break;
- case UTF8_WARN_FE_FF:
- Perl_sv_catpvf(aTHX_ sv, "(byte 0x%02"UVxf")", uv);
- break;
- case UTF8_WARN_SHORT:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)curlen, curlen == 1 ? "" : "s", (int)expectlen, startbyte);
- expectlen = curlen; /* distance for caller to skip */
- break;
- case UTF8_WARN_OVERFLOW:
- Perl_sv_catpvf(aTHX_ sv, "(overflow at 0x%"UVxf", byte 0x%02x, after start byte 0x%02"UVxf")",
- ouv, *s, startbyte);
- break;
- case UTF8_WARN_SURROGATE:
- Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
- break;
- case UTF8_WARN_LONG:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
- (int)expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
- break;
- case UTF8_WARN_FFFF:
- Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
- break;
- default:
- sv_catpvs(sv, "(unknown reason)");
- break;
}
if (warning) {
if (e != s) {
len--;
warn_and_return:
- if (ckWARN_d(WARN_UTF8)) {
- if (PL_op)
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "%s in %s", unees, OP_DESC(PL_op));
- else
- Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
- }
+ if (PL_op)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
+ "%s in %s", unees, OP_DESC(PL_op));
+ else
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
}
return len;
}
/*
+=for apidoc bytes_cmp_utf8
+
+Compares the sequence of characters (stored as octets) in b, blen with the
+sequence of characters (stored as UTF-8) in u, ulen. Returns 0 if they are
+equal, -1 or -2 if the first string is less than the second string, +1 or +2
+if the first string is greater than the second string.
+
+-1 or +1 is returned if the shorter string was identical to the start of the
+longer string. -2 or +2 is returned if the was a difference between characters
+within the strings.
+
+=cut
+*/
+
+int
+Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen)
+{
+ const U8 *const bend = b + blen;
+ const U8 *const uend = u + ulen;
+
+ PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
+
+ PERL_UNUSED_CONTEXT;
+
+ while (b < bend && u < uend) {
+ U8 c = *u++;
+ if (!UTF8_IS_INVARIANT(c)) {
+ if (UTF8_IS_DOWNGRADEABLE_START(c)) {
+ if (u < uend) {
+ U8 c1 = *u++;
+ if (UTF8_IS_CONTINUATION(c1)) {
+ c = UTF8_ACCUMULATE(NATIVE_TO_UTF(c), c1);
+ c = ASCII_TO_NATIVE(c);
+ } else {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
+ "Malformed UTF-8 character "
+ "(unexpected non-continuation byte 0x%02x"
+ ", immediately after start byte 0x%02x)"
+ /* Dear diag.t, it's in the pod. */
+ "%s%s", c1, c,
+ PL_op ? " in " : "",
+ PL_op ? OP_DESC(PL_op) : "");
+ return -2;
+ }
+ } else {
+ if (PL_op)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
+ "%s in %s", unees, OP_DESC(PL_op));
+ else
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
+ return -2; /* Really want to return undef :-) */
+ }
+ } else {
+ return -2;
+ }
+ }
+ if (*b != c) {
+ return *b < c ? -2 : +2;
+ }
+ ++b;
+ }
+
+ if (b == bend && u == uend)
+ return 0;
+
+ return b < bend ? +1 : -1;
+}
+
+/*
=for apidoc utf8_to_bytes
Converts a string C<s> of length C<len> from UTF-8 into native byte encoding.
PERL_ARGS_ASSERT_UTF16_TO_UTF8;
- if (bytelen == 1 && p[0] == 0) { /* Be understanding. */
- d[0] = 0;
- *newlen = 1;
- return d;
- }
-
if (bytelen & 1)
Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %"UVuf, (UV)bytelen);
*d++ = (U8)(( uv & 0x3f) | 0x80);
continue;
}
- if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
- UV low = (p[0] << 8) + p[1];
- p += 2;
- if (low < 0xdc00 || low >= 0xdfff)
+ if (uv >= 0xd800 && uv <= 0xdbff) { /* surrogates */
+ if (p >= pend) {
Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
- uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
+ } else {
+ UV low = (p[0] << 8) + p[1];
+ p += 2;
+ if (low < 0xdc00 || low > 0xdfff)
+ Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
+ uv = ((uv - 0xd800) << 10) + (low - 0xdc00) + 0x10000;
+ }
+ } else if (uv >= 0xdc00 && uv <= 0xdfff) {
+ Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
}
if (uv < 0x10000) {
*d++ = (U8)(( uv >> 12) | 0xe0);
PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED;
+ if (bytelen & 1)
+ Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %"UVuf,
+ (UV)bytelen);
+
while (s < send) {
const U8 tmp = s[0];
s[0] = s[1];
}
bool
+Perl_is_utf8_perl_space(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
+
+ return is_utf8_common(p, &PL_utf8_perl_space, "IsPerlSpace");
+}
+
+bool
+Perl_is_utf8_perl_word(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
+
+ return is_utf8_common(p, &PL_utf8_perl_word, "IsPerlWord");
+}
+
+bool
Perl_is_utf8_digit(pTHX_ const U8 *p)
{
dVAR;
}
bool
+Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
+
+ return is_utf8_common(p, &PL_utf8_posix_digit, "IsPosixDigit");
+}
+
+bool
Perl_is_utf8_upper(pTHX_ const U8 *p)
{
dVAR;
PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
- return is_utf8_common(p, &PL_utf8_xdigit, "Isxdigit");
+ return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
}
bool
return is_utf8_common(p, &PL_utf8_mark, "IsM");
}
+bool
+Perl_is_utf8_X_begin(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_BEGIN;
+
+ return is_utf8_common(p, &PL_utf8_X_begin, "_X_Begin");
+}
+
+bool
+Perl_is_utf8_X_extend(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_EXTEND;
+
+ return is_utf8_common(p, &PL_utf8_X_extend, "_X_Extend");
+}
+
+bool
+Perl_is_utf8_X_prepend(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_PREPEND;
+
+ return is_utf8_common(p, &PL_utf8_X_prepend, "GCB=Prepend");
+}
+
+bool
+Perl_is_utf8_X_non_hangul(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_NON_HANGUL;
+
+ return is_utf8_common(p, &PL_utf8_X_non_hangul, "HST=Not_Applicable");
+}
+
+bool
+Perl_is_utf8_X_L(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_L;
+
+ return is_utf8_common(p, &PL_utf8_X_L, "GCB=L");
+}
+
+bool
+Perl_is_utf8_X_LV(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_LV;
+
+ return is_utf8_common(p, &PL_utf8_X_LV, "GCB=LV");
+}
+
+bool
+Perl_is_utf8_X_LVT(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_LVT;
+
+ return is_utf8_common(p, &PL_utf8_X_LVT, "GCB=LVT");
+}
+
+bool
+Perl_is_utf8_X_T(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_T;
+
+ return is_utf8_common(p, &PL_utf8_X_T, "GCB=T");
+}
+
+bool
+Perl_is_utf8_X_V(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_V;
+
+ return is_utf8_common(p, &PL_utf8_X_V, "GCB=V");
+}
+
+bool
+Perl_is_utf8_X_LV_LVT_V(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_X_LV_LVT_V;
+
+ return is_utf8_common(p, &PL_utf8_X_LV_LVT_V, "_X_LV_LVT_V");
+}
+
/*
=for apidoc to_utf8_case
if (!*swashp) /* load on-demand */
*swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
+ /* This is the beginnings of a skeleton of code to read the info section
+ * that is in all the swashes in case we ever want to do that, so one can
+ * read things whose maps aren't code points, and whose default if missing
+ * is not to the code point itself. This was just to see if it actually
+ * worked. Details on what the possibilities are are in perluniprops.pod
+ HV * const hv = get_hv("utf8::SwashInfo", 0);
+ if (hv) {
+ SV **svp;
+ svp = hv_fetch(hv, (const char*)normal, strlen(normal), FALSE);
+ const char *s;
+
+ HV * const this_hash = SvRV(*svp);
+ svp = hv_fetch(this_hash, "type", strlen("type"), FALSE);
+ s = SvPV_const(*svp, len);
+ }
+ }*/
- /* The 0xDF is the only special casing Unicode code point below 0x100. */
- if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
+ if (special) {
/* It might be "special" (sometimes, but not always,
* a multicharacter mapping) */
HV * const hv = get_hv(special, 0);
}
}
- if (!len) /* Neither: just copy. */
+ if (!len) /* Neither: just copy. In other words, there was no mapping
+ defined, which means that the code point maps to itself */
len = uvchr_to_utf8(ustrp, uv0) - ustrp;
if (lenp)
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
- SAVEI32(PL_hints);
- PL_hints = 0;
+ SAVEHINTS();
save_re_context();
if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) { /* demand load utf8 */
ENTER;
ptr = tmputf8;
}
/* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
- * then the "swatch" is a vec() for al the chars which start
+ * then the "swatch" is a vec() for all the chars which start
* with 0xAA..0xYY
* So the key in the hash (klen) is length of encoded char -1
*/
off = ptr[klen];
if (klen == 0) {
- /* If char in invariant then swatch is for all the invariant chars
+ /* If char is invariant then swatch is for all the invariant chars
* In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
*/
needents = UTF_CONTINUATION_MARK;
NORETURN_FUNCTION_END;
}
+/* Read a single line of the main body of the swash input text. These are of
+ * the form:
+ * 0053 0056 0073
+ * where each number is hex. The first two numbers form the minimum and
+ * maximum of a range, and the third is the value associated with the range.
+ * Not all swashes should have a third number
+ *
+ * On input: l points to the beginning of the line to be examined; it points
+ * to somewhere in the string of the whole input text, and is
+ * terminated by a \n or the null string terminator.
+ * lend points to the null terminator of that string
+ * wants_value is non-zero if the swash expects a third number
+ * typestr is the name of the swash's mapping, like 'ToLower'
+ * On output: *min, *max, and *val are set to the values read from the line.
+ * returns a pointer just beyond the line examined. If there was no
+ * valid min number on the line, returns lend+1
+ */
+
+STATIC U8*
+S_swash_scan_list_line(pTHX_ U8* l, U8* const lend, UV* min, UV* max, UV* val,
+ const bool wants_value, const U8* const typestr)
+{
+ const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
+ STRLEN numlen; /* Length of the number */
+ I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+
+ /* nl points to the next \n in the scan */
+ U8* const nl = (U8*)memchr(l, '\n', lend - l);
+
+ /* Get the first number on the line: the range minimum */
+ numlen = lend - l;
+ *min = grok_hex((char *)l, &numlen, &flags, NULL);
+ if (numlen) /* If found a hex number, position past it */
+ l += numlen;
+ else if (nl) { /* Else, go handle next line, if any */
+ return nl + 1; /* 1 is length of "\n" */
+ }
+ else { /* Else, no next line */
+ return lend + 1; /* to LIST's end at which \n is not found */
+ }
+
+ /* The max range value follows, separated by a BLANK */
+ if (isBLANK(*l)) {
+ ++l;
+ flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
+ numlen = lend - l;
+ *max = grok_hex((char *)l, &numlen, &flags, NULL);
+ if (numlen)
+ l += numlen;
+ else /* If no value here, it is a single element range */
+ *max = *min;
+
+ /* Non-binary tables have a third entry: what the first element of the
+ * range maps to */
+ if (wants_value) {
+ if (isBLANK(*l)) {
+ ++l;
+ flags = PERL_SCAN_SILENT_ILLDIGIT |
+ PERL_SCAN_DISALLOW_PREFIX;
+ numlen = lend - l;
+ *val = grok_hex((char *)l, &numlen, &flags, NULL);
+ if (numlen)
+ l += numlen;
+ else
+ *val = 0;
+ }
+ else {
+ *val = 0;
+ if (typeto) {
+ Perl_croak(aTHX_ "%s: illegal mapping '%s'",
+ typestr, l);
+ }
+ }
+ }
+ else
+ *val = 0; /* bits == 1, then any val should be ignored */
+ }
+ else { /* Nothing following range min, should be single element with no
+ mapping expected */
+ *max = *min;
+ if (wants_value) {
+ *val = 0;
+ if (typeto) {
+ Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
+ }
+ }
+ else
+ *val = 0; /* bits == 1, then val should be ignored */
+ }
+
+ /* Position to next line if any, or EOF */
+ if (nl)
+ l = nl + 1;
+ else
+ l = lend;
+
+ return l;
+}
+
/* Note:
* Returns a swatch (a bit vector string) for a code point sequence
* that starts from the value C<start> and comprises the number C<span>.
U8 *l, *lend, *x, *xend, *s;
STRLEN lcur, xcur, scur;
HV *const hv = MUTABLE_HV(SvRV(swash));
+
+ /* The string containing the main body of the table */
SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
+
SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
- const int typeto = typestr[0] == 'T' && typestr[1] == 'o';
const STRLEN bits = SvUV(*bitssvp);
const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
const UV none = SvUV(*nonesvp);
lend = l + lcur;
while (l < lend) {
UV min, max, val;
- STRLEN numlen;
- I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
-
- U8* const nl = (U8*)memchr(l, '\n', lend - l);
-
- numlen = lend - l;
- min = grok_hex((char *)l, &numlen, &flags, NULL);
- if (numlen)
- l += numlen;
- else if (nl) {
- l = nl + 1; /* 1 is length of "\n" */
- continue;
- }
- else {
- l = lend; /* to LIST's end at which \n is not found */
+ l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
+ cBOOL(octets), typestr);
+ if (l > lend) {
break;
}
- if (isBLANK(*l)) {
- ++l;
- flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_DISALLOW_PREFIX;
- numlen = lend - l;
- max = grok_hex((char *)l, &numlen, &flags, NULL);
- if (numlen)
- l += numlen;
- else
- max = min;
-
- if (octets) {
- if (isBLANK(*l)) {
- ++l;
- flags = PERL_SCAN_SILENT_ILLDIGIT |
- PERL_SCAN_DISALLOW_PREFIX;
- numlen = lend - l;
- val = grok_hex((char *)l, &numlen, &flags, NULL);
- if (numlen)
- l += numlen;
- else
- val = 0;
- }
- else {
- val = 0;
- if (typeto) {
- Perl_croak(aTHX_ "%s: illegal mapping '%s'",
- typestr, l);
- }
- }
- }
- else
- val = 0; /* bits == 1, then val should be ignored */
- }
- else {
- max = min;
- if (octets) {
- val = 0;
- if (typeto) {
- Perl_croak(aTHX_ "%s: illegal mapping '%s'", typestr, l);
- }
- }
- else
- val = 0; /* bits == 1, then val should be ignored */
- }
-
- if (nl)
- l = nl + 1;
- else
- l = lend;
-
+ /* If looking for something beyond this range, go try the next one */
if (max < start)
continue;
return swatch;
}
+HV*
+Perl__swash_inversion_hash(pTHX_ SV* swash)
+{
+
+ /* Subject to change or removal. For use only in one place in regexec.c
+ *
+ * Returns a hash which is the inversion and closure of a swash mapping.
+ * For example, consider the input lines:
+ * 004B 006B
+ * 004C 006C
+ * 212A 006B
+ *
+ * The returned hash would have two keys, the utf8 for 006B and the utf8 for
+ * 006C. The value for each key is an array. For 006C, the array would
+ * have a two elements, the utf8 for itself, and for 004C. For 006B, there
+ * would be three elements in its array, the utf8 for 006B, 004B and 212A.
+ *
+ * Essentially, for any code point, it gives all the code points that map to
+ * it, or the list of 'froms' for that point.
+ *
+ * Currently it only looks at the main body of the swash, and ignores any
+ * additions or deletions from other swashes */
+
+ U8 *l, *lend;
+ STRLEN lcur;
+ HV *const hv = MUTABLE_HV(SvRV(swash));
+
+ /* The string containing the main body of the table */
+ SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
+
+ SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
+ SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
+ SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
+ /*SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);*/
+ const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
+ const STRLEN bits = SvUV(*bitssvp);
+ const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
+ const UV none = SvUV(*nonesvp);
+
+ HV* ret = newHV();
+
+ PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
+
+ /* Must have at least 8 bits to get the mappings */
+ if (bits != 8 && bits != 16 && bits != 32) {
+ Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"UVuf,
+ (UV)bits);
+ }
+
+ /* read $swash->{LIST} */
+ l = (U8*)SvPV(*listsvp, lcur);
+ lend = l + lcur;
+
+ /* Go through each input line */
+ while (l < lend) {
+ UV min, max, val;
+ UV inverse;
+ l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
+ cBOOL(octets), typestr);
+ if (l > lend) {
+ break;
+ }
+
+ /* Each element in the range is to be inverted */
+ for (inverse = min; inverse <= max; inverse++) {
+ AV* list;
+ SV* element;
+ SV** listp;
+ IV i;
+ bool found_key = FALSE;
+
+ /* The key is the inverse mapping */
+ char key[UTF8_MAXBYTES+1];
+ char* key_end = (char *) uvuni_to_utf8((U8*) key, val);
+ STRLEN key_len = key_end - key;
+
+ /* And the value is what the forward mapping is from. */
+ char utf8_inverse[UTF8_MAXBYTES+1];
+ char *utf8_inverse_end = (char *) uvuni_to_utf8((U8*) utf8_inverse, inverse);
+
+ /* Get the list for the map */
+ if ((listp = hv_fetch(ret, key, key_len, FALSE))) {
+ list = (AV*) *listp;
+ }
+ else { /* No entry yet for it: create one */
+ list = newAV();
+ if (! hv_store(ret, key, key_len, (SV*) list, FALSE)) {
+ Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+ }
+ }
+
+ for (i = 0; i < av_len(list); i++) {
+ SV** entryp = av_fetch(list, i, FALSE);
+ SV* entry;
+ if (entryp == NULL) {
+ Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
+ }
+ entry = *entryp;
+ if (SvCUR(entry) != key_len) {
+ continue;
+ }
+ if (memEQ(key, SvPVX(entry), key_len)) {
+ found_key = TRUE;
+ break;
+ }
+ }
+ if (! found_key) {
+ element = newSVpvn_flags(key, key_len, SVf_UTF8);
+ av_push(list, element);
+ }
+
+
+ /* Simply add the value to the list */
+ element = newSVpvn_flags(utf8_inverse, utf8_inverse_end - utf8_inverse, SVf_UTF8);
+ av_push(list, element);
+
+ /* swash_get() increments the value of val for each element in the
+ * range. That makes more compact tables possible. You can
+ * express the capitalization, for example, of all consecutive
+ * letters with a single line: 0061\t007A\t0041 This maps 0061 to
+ * 0041, 0062 to 0042, etc. I (khw) have never understood 'none',
+ * and it's not documented, and perhaps not even currently used,
+ * but I copied the semantics from swash_get(), just in case */
+ if (!none || val < none) {
+ ++val;
+ }
+ }
+ }
+
+ return ret;
+}
+
/*
=for apidoc uvchr_to_utf8
=for apidoc utf8n_to_uvchr
flags
-Returns the native character value of the first character in the string
+Returns the native character value of the first character in the string
C<s>
which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
a real function in case XS code wants it
*/
UV
-Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
+Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen,
U32 flags)
{
const UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
}
if (truncated)
sv_catpvs(dsv, "...");
-
+
return SvPVX(dsv);
}
}
/*
-=for apidoc ibcmp_utf8
-
-Return true if the strings s1 and s2 differ case-insensitively, false
-if not (if they are equal case-insensitively). If u1 is true, the
-string s1 is assumed to be in UTF-8-encoded Unicode. If u2 is true,
-the string s2 is assumed to be in UTF-8-encoded Unicode. If u1 or u2
-are false, the respective string is assumed to be in native 8-bit
-encoding.
-
-If the pe1 and pe2 are non-NULL, the scanning pointers will be copied
-in there (they will point at the beginning of the I<next> character).
-If the pointers behind pe1 or pe2 are non-NULL, they are the end
-pointers beyond which scanning will not continue under any
-circumstances. If the byte lengths l1 and l2 are non-zero, s1+l1 and
-s2+l2 will be used as goal end pointers that will also stop the scan,
-and which qualify towards defining a successful match: all the scans
-that define an explicit length must reach their goal pointers for
-a match to succeed).
+=for apidoc foldEQ_utf8
+
+Returns true if the leading portions of the strings s1 and s2 (either or both
+of which may be in UTF-8) are the same case-insensitively; false otherwise.
+How far into the strings to compare is determined by other input parameters.
+
+If u1 is true, the string s1 is assumed to be in UTF-8-encoded Unicode;
+otherwise it is assumed to be in native 8-bit encoding. Correspondingly for u2
+with respect to s2.
+
+If the byte length l1 is non-zero, it says how far into s1 to check for fold
+equality. In other words, s1+l1 will be used as a goal to reach. The
+scan will not be considered to be a match unless the goal is reached, and
+scanning won't continue past that goal. Correspondingly for l2 with respect to
+s2.
+
+If pe1 is non-NULL and the pointer it points to is not NULL, that pointer is
+considered an end pointer beyond which scanning of s1 will not continue under
+any circumstances. This means that if both l1 and pe1 are specified, and pe1
+is less than s1+l1, the match will never be successful because it can never
+get as far as its goal (and in fact is asserted against). Correspondingly for
+pe2 with respect to s2.
+
+At least one of s1 and s2 must have a goal (at least one of l1 and l2 must be
+non-zero), and if both do, both have to be
+reached for a successful match. Also, if the fold of a character is multiple
+characters, all of them must be matched (see tr21 reference below for
+'folding').
+
+Upon a successful match, if pe1 is non-NULL,
+it will be set to point to the beginning of the I<next> character of s1 beyond
+what was matched. Correspondingly for pe2 and s2.
For case-insensitiveness, the "casefolding" of Unicode is used
instead of upper/lowercasing both the characters, see
=cut */
I32
-Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
-{
- dVAR;
- register const U8 *p1 = (const U8*)s1;
- register const U8 *p2 = (const U8*)s2;
- register const U8 *f1 = NULL;
- register const U8 *f2 = NULL;
- register U8 *e1 = NULL;
- register U8 *q1 = NULL;
- register U8 *e2 = NULL;
- register U8 *q2 = NULL;
- STRLEN n1 = 0, n2 = 0;
- U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
- U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
- U8 natbuf[1+1];
- STRLEN foldlen1, foldlen2;
- bool match;
-
- PERL_ARGS_ASSERT_IBCMP_UTF8;
-
- if (pe1)
- e1 = *(U8**)pe1;
- /* assert(e1 || l1); */
- if (e1 == 0 || (l1 && l1 < (UV)(e1 - (const U8*)s1)))
- f1 = (const U8*)s1 + l1;
- if (pe2)
- e2 = *(U8**)pe2;
- /* assert(e2 || l2); */
- if (e2 == 0 || (l2 && l2 < (UV)(e2 - (const U8*)s2)))
- f2 = (const U8*)s2 + l2;
-
- /* This shouldn't happen. However, putting an assert() there makes some
- * tests fail. */
- /* assert((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0)); */
- if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
- return 1; /* mismatch; possible infinite loop or false positive */
-
- if (!u1 || !u2)
- natbuf[1] = 0; /* Need to terminate the buffer. */
-
- while ((e1 == 0 || p1 < e1) &&
- (f1 == 0 || p1 < f1) &&
- (e2 == 0 || p2 < e2) &&
- (f2 == 0 || p2 < f2)) {
- if (n1 == 0) {
- if (u1)
- to_utf8_fold(p1, foldbuf1, &foldlen1);
- else {
- uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
- to_utf8_fold(natbuf, foldbuf1, &foldlen1);
- }
- q1 = foldbuf1;
- n1 = foldlen1;
- }
- if (n2 == 0) {
- if (u2)
- to_utf8_fold(p2, foldbuf2, &foldlen2);
- else {
- uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
- to_utf8_fold(natbuf, foldbuf2, &foldlen2);
- }
- q2 = foldbuf2;
- n2 = foldlen2;
- }
- while (n1 && n2) {
- if ( UTF8SKIP(q1) != UTF8SKIP(q2) ||
- (UTF8SKIP(q1) == 1 && *q1 != *q2) ||
- memNE((char*)q1, (char*)q2, UTF8SKIP(q1)) )
- return 1; /* mismatch */
- n1 -= UTF8SKIP(q1);
- q1 += UTF8SKIP(q1);
- n2 -= UTF8SKIP(q2);
- q2 += UTF8SKIP(q2);
- }
- if (n1 == 0)
- p1 += u1 ? UTF8SKIP(p1) : 1;
- if (n2 == 0)
- p2 += u2 ? UTF8SKIP(p2) : 1;
-
- }
-
- /* A match is defined by all the scans that specified
- * an explicit length reaching their final goals. */
- match = (f1 == 0 || p1 == f1) && (f2 == 0 || p2 == f2);
-
- if (match) {
- if (pe1)
- *pe1 = (char*)p1;
- if (pe2)
- *pe2 = (char*)p2;
- }
-
- return match ? 0 : 1; /* 0 match, 1 mismatch */
+Perl_foldEQ_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
+{
+ dVAR;
+ register const U8 *p1 = (const U8*)s1; /* Point to current char */
+ register const U8 *p2 = (const U8*)s2;
+ register const U8 *g1 = NULL; /* goal for s1 */
+ register const U8 *g2 = NULL;
+ register const U8 *e1 = NULL; /* Don't scan s1 past this */
+ register U8 *f1 = NULL; /* Point to current folded */
+ register const U8 *e2 = NULL;
+ register U8 *f2 = NULL;
+ STRLEN n1 = 0, n2 = 0; /* Number of bytes in current char */
+ U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
+ U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
+ U8 natbuf[2]; /* Holds native 8-bit char converted to utf8;
+ these always fit in 2 bytes */
+
+ PERL_ARGS_ASSERT_FOLDEQ_UTF8;
+
+ if (pe1) {
+ e1 = *(U8**)pe1;
+ }
+
+ if (l1) {
+ g1 = (const U8*)s1 + l1;
+ }
+
+ if (pe2) {
+ e2 = *(U8**)pe2;
+ }
+
+ if (l2) {
+ g2 = (const U8*)s2 + l2;
+ }
+
+ /* Must have at least one goal */
+ assert(g1 || g2);
+
+ if (g1) {
+
+ /* Will never match if goal is out-of-bounds */
+ assert(! e1 || e1 >= g1);
+
+ /* Here, there isn't an end pointer, or it is beyond the goal. We
+ * only go as far as the goal */
+ e1 = g1;
+ }
+ else {
+ assert(e1); /* Must have an end for looking at s1 */
+ }
+
+ /* Same for goal for s2 */
+ if (g2) {
+ assert(! e2 || e2 >= g2);
+ e2 = g2;
+ }
+ else {
+ assert(e2);
+ }
+
+ /* Look through both strings, a character at a time */
+ while (p1 < e1 && p2 < e2) {
+
+ /* If at the beginning of a new character in s1, get its fold to use
+ * and the length of the fold */
+ if (n1 == 0) {
+ if (u1) {
+ to_utf8_fold(p1, foldbuf1, &n1);
+ }
+ else { /* Not utf8, convert to it first and then get fold */
+ uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p1)));
+ to_utf8_fold(natbuf, foldbuf1, &n1);
+ }
+ f1 = foldbuf1;
+ }
+
+ if (n2 == 0) { /* Same for s2 */
+ if (u2) {
+ to_utf8_fold(p2, foldbuf2, &n2);
+ }
+ else {
+ uvuni_to_utf8(natbuf, (UV) NATIVE_TO_UNI(((UV)*p2)));
+ to_utf8_fold(natbuf, foldbuf2, &n2);
+ }
+ f2 = foldbuf2;
+ }
+
+ /* While there is more to look for in both folds, see if they
+ * continue to match */
+ while (n1 && n2) {
+ U8 fold_length = UTF8SKIP(f1);
+ if (fold_length != UTF8SKIP(f2)
+ || (fold_length == 1 && *f1 != *f2) /* Short circuit memNE
+ function call for single
+ character */
+ || memNE((char*)f1, (char*)f2, fold_length))
+ {
+ return 0; /* mismatch */
+ }
+
+ /* Here, they matched, advance past them */
+ n1 -= fold_length;
+ f1 += fold_length;
+ n2 -= fold_length;
+ f2 += fold_length;
+ }
+
+ /* When reach the end of any fold, advance the input past it */
+ if (n1 == 0) {
+ p1 += u1 ? UTF8SKIP(p1) : 1;
+ }
+ if (n2 == 0) {
+ p2 += u2 ? UTF8SKIP(p2) : 1;
+ }
+ } /* End of loop through both strings */
+
+ /* A match is defined by each scan that specified an explicit length
+ * reaching its final goal, and the other not having matched a partial
+ * character (which can happen when the fold of a character is more than one
+ * character). */
+ if (! ((g1 == 0 || p1 == g1) && (g2 == 0 || p2 == g2)) || n1 || n2) {
+ return 0;
+ }
+
+ /* Successful match. Set output pointers */
+ if (pe1) {
+ *pe1 = (char*)p1;
+ }
+ if (pe2) {
+ *pe2 = (char*)p2;
+ }
+ return 1;
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff