/* utf8.c
*
- * Copyright (c) 1998-2001, Larry Wall
+ * Copyright (C) 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define PERL_IN_UTF8_C
#include "perl.h"
-/* Unicode support */
+static char unees[] = "Malformed UTF-8 character (unexpected end of string)";
-/*
-=for apidoc A|U8 *|uvuni_to_utf8|U8 *d|UV uv
+/*
+=head1 Unicode Support
+
+This file contains various utility functions for manipulating UTF8-encoded
+strings. For the uninitiated, this is a method of representing arbitrary
+Unicode characters as a variable number of bytes, in such a way that
+characters in the ASCII range are unmodified, and a zero byte never appears.
+
+=for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
-Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
+Adds the UTF-8 representation of the Unicode codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
+ d = uvuni_to_utf8_flags(d, uv, flags);
+
+or, in most cases,
+
d = uvuni_to_utf8(d, uv);
+(which is equivalent to)
+
+ d = uvuni_to_utf8_flags(d, uv, 0);
+
is the recommended Unicode-aware way of saying
*(d++) = uv;
*/
U8 *
-Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
-{
+Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+{
+ if (ckWARN(WARN_UTF8)) {
+ if (UNICODE_IS_SURROGATE(uv) &&
+ !(flags & UNICODE_ALLOW_SURROGATE))
+ Perl_warner(aTHX_ packWARN(WARN_UTF8), "UTF-16 surrogate 0x%04"UVxf, uv);
+ else if (
+ ((uv >= 0xFDD0 && uv <= 0xFDEF &&
+ !(flags & UNICODE_ALLOW_FDD0))
+ ||
+ ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
+ !(flags & UNICODE_ALLOW_FFFF))) &&
+ /* UNICODE_ALLOW_SUPER includes
+ * FFFEs and FFFFs beyond 0x10FFFF. */
+ ((uv <= PERL_UNICODE_MAX) ||
+ !(flags & UNICODE_ALLOW_SUPER))
+ )
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "Unicode character 0x%04"UVxf" is illegal", uv);
+ }
if (UNI_IS_INVARIANT(uv)) {
- *d++ = UTF_TO_NATIVE(uv);
+ *d++ = (U8)UTF_TO_NATIVE(uv);
return d;
}
#if defined(EBCDIC)
STRLEN len = UNISKIP(uv);
U8 *p = d+len-1;
while (p > d) {
- *p-- = UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
+ *p-- = (U8)UTF_TO_NATIVE((uv & UTF_CONTINUATION_MASK) | UTF_CONTINUATION_MARK);
uv >>= UTF_ACCUMULATION_SHIFT;
}
- *p = UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
+ *p = (U8)UTF_TO_NATIVE((uv & UTF_START_MASK(len)) | UTF_START_MARK(len));
return d+len;
}
#else /* Non loop style */
if (uv < 0x800) {
- *d++ = (( uv >> 6) | 0xc0);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 6) | 0xc0);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
if (uv < 0x10000) {
- *d++ = (( uv >> 12) | 0xe0);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 12) | 0xe0);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
if (uv < 0x200000) {
- *d++ = (( uv >> 18) | 0xf0);
- *d++ = (((uv >> 12) & 0x3f) | 0x80);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 18) | 0xf0);
+ *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
if (uv < 0x4000000) {
- *d++ = (( uv >> 24) | 0xf8);
- *d++ = (((uv >> 18) & 0x3f) | 0x80);
- *d++ = (((uv >> 12) & 0x3f) | 0x80);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 24) | 0xf8);
+ *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
if (uv < 0x80000000) {
- *d++ = (( uv >> 30) | 0xfc);
- *d++ = (((uv >> 24) & 0x3f) | 0x80);
- *d++ = (((uv >> 18) & 0x3f) | 0x80);
- *d++ = (((uv >> 12) & 0x3f) | 0x80);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 30) | 0xfc);
+ *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
#ifdef HAS_QUAD
if (uv < UTF8_QUAD_MAX)
#endif
{
- *d++ = 0xfe; /* Can't match U+FEFF! */
- *d++ = (((uv >> 30) & 0x3f) | 0x80);
- *d++ = (((uv >> 24) & 0x3f) | 0x80);
- *d++ = (((uv >> 18) & 0x3f) | 0x80);
- *d++ = (((uv >> 12) & 0x3f) | 0x80);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = 0xfe; /* Can't match U+FEFF! */
+ *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
#ifdef HAS_QUAD
{
- *d++ = 0xff; /* Can't match U+FFFE! */
- *d++ = 0x80; /* 6 Reserved bits */
- *d++ = (((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
- *d++ = (((uv >> 54) & 0x3f) | 0x80);
- *d++ = (((uv >> 48) & 0x3f) | 0x80);
- *d++ = (((uv >> 42) & 0x3f) | 0x80);
- *d++ = (((uv >> 36) & 0x3f) | 0x80);
- *d++ = (((uv >> 30) & 0x3f) | 0x80);
- *d++ = (((uv >> 24) & 0x3f) | 0x80);
- *d++ = (((uv >> 18) & 0x3f) | 0x80);
- *d++ = (((uv >> 12) & 0x3f) | 0x80);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = 0xff; /* Can't match U+FFFE! */
+ *d++ = 0x80; /* 6 Reserved bits */
+ *d++ = (U8)(((uv >> 60) & 0x0f) | 0x80); /* 2 Reserved bits */
+ *d++ = (U8)(((uv >> 54) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 48) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 42) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 36) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 30) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 24) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 18) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
return d;
}
#endif
#endif /* Loop style */
}
-
+
+U8 *
+Perl_uvuni_to_utf8(pTHX_ U8 *d, UV uv)
+{
+ return Perl_uvuni_to_utf8_flags(aTHX_ d, uv, 0);
+}
/*
=for apidoc A|STRLEN|is_utf8_char|U8 *s
Tests if some arbitrary number of bytes begins in a valid UTF-8
-character. Note that an INVARIANT (i.e. ASCII) character is a valid UTF-8 character.
-The actual number of bytes in the UTF-8 character will be returned if
-it is valid, otherwise 0.
+character. Note that an INVARIANT (i.e. ASCII) character is a valid
+UTF-8 character. The actual number of bytes in the UTF-8 character
+will be returned if it is valid, otherwise 0.
-=cut
-*/
+=cut */
STRLEN
Perl_is_utf8_char(pTHX_ U8 *s)
{
s++;
}
- if (UNISKIP(uv) < len)
+ if ((STRLEN)UNISKIP(uv) < len)
return 0;
return len;
/*
=for apidoc A|bool|is_utf8_string|U8 *s|STRLEN len
-Returns true if first C<len> bytes of the given string form a valid UTF8
-string, false otherwise. Note that 'a valid UTF8 string' does not mean
-'a string that contains UTF8' because a valid ASCII string is a valid
-UTF8 string.
+Returns true if first C<len> bytes of the given string form a valid
+UTF-8 string, false otherwise. Note that 'a valid UTF-8 string' does
+not mean 'a string that contains code points above 0x7F encoded in UTF-8'
+because a valid ASCII string is a valid UTF-8 string.
=cut
*/
U8* send;
STRLEN c;
- if (!len)
+ if (!len && s)
len = strlen((char *)s);
send = s + len;
while (x < send) {
- c = is_utf8_char(x);
- if (!c)
- return FALSE;
+ /* Inline the easy bits of is_utf8_char() here for speed... */
+ if (UTF8_IS_INVARIANT(*x))
+ c = 1;
+ else if (!UTF8_IS_START(*x))
+ return FALSE;
+ else {
+ /* ... and call is_utf8_char() only if really needed. */
+ c = is_utf8_char(x);
+ if (!c)
+ return FALSE;
+ }
x += c;
}
if (x != send)
}
/*
+=for apidoc A|bool|is_utf8_string_loc|U8 *s|STRLEN len|U8 **p
+
+Like is_ut8_string but store the location of the failure in
+the last argument.
+
+=cut
+*/
+
+bool
+Perl_is_utf8_string_loc(pTHX_ U8 *s, STRLEN len, U8 **p)
+{
+ U8* x = s;
+ U8* send;
+ STRLEN c;
+
+ if (!len && s)
+ len = strlen((char *)s);
+ send = s + len;
+
+ while (x < send) {
+ /* Inline the easy bits of is_utf8_char() here for speed... */
+ if (UTF8_IS_INVARIANT(*x))
+ c = 1;
+ else if (!UTF8_IS_START(*x)) {
+ if (p)
+ *p = x;
+ return FALSE;
+ }
+ else {
+ /* ... and call is_utf8_char() only if really needed. */
+ c = is_utf8_char(x);
+ if (!c) {
+ if (p)
+ *p = x;
+ return FALSE;
+ }
+ }
+ x += c;
+ }
+ if (x != send) {
+ if (p)
+ *p = x;
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
+/*
=for apidoc A|UV|utf8n_to_uvuni|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
Bottom level UTF-8 decode routine.
Returns the unicode code point value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding and no longer than C<curlen>;
+which is assumed to be in UTF-8 encoding and no longer than C<curlen>;
C<retlen> will be set to the length, in bytes, of that character.
-If C<s> does not point to a well-formed UTF8 character, the behaviour
+If C<s> does not point to a well-formed UTF-8 character, the behaviour
is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
it is assumed that the caller will raise a warning, and this function
will silently just set C<retlen> to C<-1> and return zero. If the
UV
Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
+ U8 *s0 = s;
UV uv = *s, ouv = 0;
STRLEN len = 1;
bool dowarn = ckWARN_d(WARN_UTF8);
+ UV startbyte = *s;
STRLEN expectlen = 0;
U32 warning = 0;
#define UTF8_WARN_SHORT 5
#define UTF8_WARN_OVERFLOW 6
#define UTF8_WARN_SURROGATE 7
-#define UTF8_WARN_BOM 8
-#define UTF8_WARN_LONG 9
-#define UTF8_WARN_FFFF 10
+#define UTF8_WARN_LONG 8
+#define UTF8_WARN_FFFF 9 /* Also FFFE. */
if (curlen == 0 &&
!(flags & UTF8_ALLOW_EMPTY)) {
!(flags & UTF8_ALLOW_SURROGATE)) {
warning = UTF8_WARN_SURROGATE;
goto malformed;
- } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
- !(flags & UTF8_ALLOW_BOM)) {
- warning = UTF8_WARN_BOM;
- goto malformed;
- } else if ((expectlen > UNISKIP(uv)) &&
+ } else if ((expectlen > (STRLEN)UNISKIP(uv)) &&
!(flags & UTF8_ALLOW_LONG)) {
warning = UTF8_WARN_LONG;
goto malformed;
Perl_sv_catpvf(aTHX_ sv, "(empty string)");
break;
case UTF8_WARN_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf")", uv);
+ Perl_sv_catpvf(aTHX_ sv, "(unexpected continuation byte 0x%02"UVxf", with no preceding start byte)", uv);
break;
case UTF8_WARN_NON_CONTINUATION:
- Perl_sv_catpvf(aTHX_ sv, "(unexpected non-continuation byte 0x%02"UVxf" after start byte 0x%02"UVxf")",
- (UV)s[1], uv);
+ 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
+ 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], s - s0, s - s0 > 1 ? "s" : "", startbyte, 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)",
- curlen, curlen == 1 ? "" : "s", expectlen);
+ Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
+ curlen, curlen == 1 ? "" : "s", 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)",
- ouv, *s);
+ 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_BOM:
- Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
- break;
case UTF8_WARN_LONG:
- Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d)",
- expectlen, expectlen == 1 ? "": "s", UNISKIP(uv));
+ Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
+ expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
break;
case UTF8_WARN_FFFF:
Perl_sv_catpvf(aTHX_ sv, "(character 0x%04"UVxf")", uv);
char *s = SvPVX(sv);
if (PL_op)
- Perl_warner(aTHX_ WARN_UTF8,
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
"%s in %s", s, OP_DESC(PL_op));
else
- Perl_warner(aTHX_ WARN_UTF8, "%s", s);
+ Perl_warner(aTHX_ packWARN(WARN_UTF8), "%s", s);
}
}
=for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
Returns the native character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
-If C<s> does not point to a well-formed UTF8 character, zero is
+If C<s> does not point to a well-formed UTF-8 character, zero is
returned and retlen is set, if possible, to -1.
=cut
UV
Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
{
- return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0);
+ return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen,
+ ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
}
/*
=for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
Returns the Unicode code point of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
This function should only be used when returned UV is considered
an index into the Unicode semantic tables (e.g. swashes).
-If C<s> does not point to a well-formed UTF8 character, zero is
+If C<s> does not point to a well-formed UTF-8 character, zero is
returned and retlen is set, if possible, to -1.
=cut
Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
{
/* Call the low level routine asking for checks */
- return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0);
+ return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen,
+ ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
}
/*
* the bitops (especially ~) can create illegal UTF-8.
* In other words: in Perl UTF-8 is not just for Unicode. */
- if (e < s)
- Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
+ if (e < s) {
+ 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);
+ }
+ return 0;
+ }
while (s < e) {
U8 t = UTF8SKIP(s);
- if (e - s < t)
- Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
+ if (e - s < t) {
+ if (ckWARN_d(WARN_UTF8)) {
+ if (PL_op)
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ unees, OP_DESC(PL_op));
+ else
+ Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
+ }
+ return len;
+ }
s += t;
len++;
}
/*
=for apidoc A|IV|utf8_distance|U8 *a|U8 *b
-Returns the number of UTF8 characters between the UTF-8 pointers C<a>
+Returns the number of UTF
-8 characters between the UTF-8 pointers C<a>
and C<b>.
WARNING: use only if you *know* that the pointers point inside the
while (a < b) {
U8 c = UTF8SKIP(a);
- if (b - a < c)
- Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+ if (b - a < c) {
+ 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);
+ }
+ return off;
+ }
a += c;
off--;
}
while (b < a) {
U8 c = UTF8SKIP(b);
- if (a - b < c)
- Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+ if (a - b < c) {
+ 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);
+ }
+ return off;
+ }
b += c;
off++;
}
/*
=for apidoc A|U8 *|utf8_to_bytes|U8 *s|STRLEN *len
-Converts a string C<s> of length C<len> from UTF8 into byte encoding.
+Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
Unlike C<bytes_to_utf8>, this over-writes the original string, and
updates len to contain the new length.
Returns zero on failure, setting C<len> to -1.
U8 *d;
U8 *save = s;
- /* ensure valid UTF8 and chars < 256 before updating string */
+ /* ensure valid UTF-8 and chars < 256 before updating string */
for (send = s + *len; s < send; ) {
U8 c = *s++;
/*
=for apidoc A|U8 *|bytes_from_utf8|U8 *s|STRLEN *len|bool *is_utf8
-Converts a string C<s> of length C<len> from UTF8 into byte encoding.
+Converts a string C<s> of length C<len> from UTF-8 into byte encoding.
Unlike <utf8_to_bytes> but like C<bytes_to_utf8>, returns a pointer to
the newly-created string, and updates C<len> to contain the new
length. Returns the original string if no conversion occurs, C<len>
if (!*is_utf8)
return start;
- /* ensure valid UTF8 and chars < 256 before converting string */
+ /* ensure valid UTF-8 and chars < 256 before converting string */
for (send = s + *len; s < send;) {
U8 c = *s++;
if (!UTF8_IS_INVARIANT(c)) {
/*
=for apidoc A|U8 *|bytes_to_utf8|U8 *s|STRLEN *len
-Converts a string C<s> of length C<len> from ASCII into UTF8 encoding.
+Converts a string C<s> of length C<len> from ASCII into UTF-8 encoding.
Returns a pointer to the newly-created string, and sets C<len> to
reflect the new length.
+If you want to convert to UTF-8 from other encodings than ASCII,
+see sv_recode_to_utf8().
+
=cut
*/
while (s < send) {
UV uv = NATIVE_TO_ASCII(*s++);
if (UNI_IS_INVARIANT(uv))
- *d++ = UTF_TO_NATIVE(uv);
+ *d++ = (U8)UTF_TO_NATIVE(uv);
else {
- *d++ = UTF8_EIGHT_BIT_HI(uv);
- *d++ = UTF8_EIGHT_BIT_LO(uv);
+ *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
+ *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
}
}
*d = '\0';
UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */
p += 2;
if (uv < 0x80) {
- *d++ = uv;
+ *d++ = (U8)uv;
continue;
}
if (uv < 0x800) {
- *d++ = (( uv >> 6) | 0xc0);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 6) | 0xc0);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
continue;
}
if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */
- UV low = *p++;
+ 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;
}
if (uv < 0x10000) {
- *d++ = (( uv >> 12) | 0xe0);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 12) | 0xe0);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
continue;
}
else {
- *d++ = (( uv >> 18) | 0xf0);
- *d++ = (((uv >> 12) & 0x3f) | 0x80);
- *d++ = (((uv >> 6) & 0x3f) | 0x80);
- *d++ = (( uv & 0x3f) | 0x80);
+ *d++ = (U8)(( uv >> 18) | 0xf0);
+ *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80);
+ *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80);
+ *d++ = (U8)(( uv & 0x3f) | 0x80);
continue;
}
}
Perl_is_uni_alnum(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_alnum(tmpbuf);
}
Perl_is_uni_alnumc(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_alnumc(tmpbuf);
}
Perl_is_uni_idfirst(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_idfirst(tmpbuf);
}
Perl_is_uni_alpha(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_alpha(tmpbuf);
}
Perl_is_uni_ascii(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_ascii(tmpbuf);
}
Perl_is_uni_space(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_space(tmpbuf);
}
Perl_is_uni_digit(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_digit(tmpbuf);
}
Perl_is_uni_upper(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_upper(tmpbuf);
}
Perl_is_uni_lower(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_lower(tmpbuf);
}
Perl_is_uni_cntrl(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_cntrl(tmpbuf);
}
Perl_is_uni_graph(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_graph(tmpbuf);
}
Perl_is_uni_print(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_print(tmpbuf);
}
Perl_is_uni_punct(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_punct(tmpbuf);
}
Perl_is_uni_xdigit(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_xdigit(tmpbuf);
}
UV
Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
- return to_utf8_upper(tmpbuf, p, lenp);
+ uvchr_to_utf8(p, c);
+ return to_utf8_upper(p, p, lenp);
}
UV
Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
- return to_utf8_title(tmpbuf, p, lenp);
+ uvchr_to_utf8(p, c);
+ return to_utf8_title(p, p, lenp);
}
UV
Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
- return to_utf8_lower(tmpbuf, p, lenp);
+ uvchr_to_utf8(p, c);
+ return to_utf8_lower(p, p, lenp);
}
UV
Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
- return to_utf8_fold(tmpbuf, p, lenp);
+ uvchr_to_utf8(p, c);
+ return to_utf8_fold(p, 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)
+{
+ /* XXX returns only the first character -- do not use XXX */
+ /* XXX no locale support yet */
+ STRLEN len;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ return (U32)to_uni_upper(c, tmpbuf, &len);
+}
+
+U32
+Perl_to_uni_title_lc(pTHX_ U32 c)
+{
+ /* XXX returns only the first character XXX -- do not use XXX */
+ /* XXX no locale support yet */
+ STRLEN len;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ return (U32)to_uni_title(c, tmpbuf, &len);
+}
+
+U32
+Perl_to_uni_lower_lc(pTHX_ U32 c)
+{
+ /* XXX returns only the first character -- do not use XXX */
+ /* XXX no locale support yet */
+ STRLEN len;
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
+ return (U32)to_uni_lower(c, tmpbuf, &len);
+}
+
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, TRUE);
+ return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
/* 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, TRUE);
+ return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
#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, TRUE);
+ return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
/* 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, TRUE);
+ return swash_fetch(PL_utf8_alnum, p, TRUE) != 0;
#endif
}
bool
-Perl_is_utf8_idfirst(pTHX_ U8 *p)
+Perl_is_utf8_idfirst(pTHX_ U8 *p) /* The naming is historical. */
{
- return *p == '_' || is_utf8_alpha(p);
+ if (*p == '_')
+ return TRUE;
+ if (!is_utf8_char(p))
+ return FALSE;
+ if (!PL_utf8_idstart) /* is_utf8_idstart would be more logical. */
+ PL_utf8_idstart = swash_init("utf8", "IdStart", &PL_sv_undef, 0, 0);
+ return swash_fetch(PL_utf8_idstart, p, TRUE) != 0;
+}
+
+bool
+Perl_is_utf8_idcont(pTHX_ U8 *p)
+{
+ if (*p == '_')
+ return TRUE;
+ if (!is_utf8_char(p))
+ return FALSE;
+ if (!PL_utf8_idcont)
+ PL_utf8_idcont = swash_init("utf8", "IdContinue", &PL_sv_undef, 0, 0);
+ return swash_fetch(PL_utf8_idcont, p, TRUE) != 0;
}
bool
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, TRUE);
+ return swash_fetch(PL_utf8_alpha, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_ascii, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_space, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_digit, p, TRUE) != 0;
}
bool
if (!is_utf8_char(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, TRUE);
+ PL_utf8_upper = swash_init("utf8", "IsUppercase", &PL_sv_undef, 0, 0);
+ return swash_fetch(PL_utf8_upper, p, TRUE) != 0;
}
bool
if (!is_utf8_char(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, TRUE);
+ PL_utf8_lower = swash_init("utf8", "IsLowercase", &PL_sv_undef, 0, 0);
+ return swash_fetch(PL_utf8_lower, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_cntrl, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_graph, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_print, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_punct, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_xdigit, p, TRUE) != 0;
}
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, TRUE);
+ return swash_fetch(PL_utf8_mark, p, TRUE) != 0;
}
/*
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 "swashp" 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.
+Both the special and normal mappings are stored lib/unicore/To/Foo.pl,
+and loaded by SWASHGET, using lib/utf8_heavy.pl. The special (usually,
+but not always, a multicharacter mapping), is tried first.
-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().
+The "special" is a string like "utf8::ToSpecLower", which means the
+hash %utf8::ToSpecLower. The access to the hash is through
+Perl_to_utf8_case().
-=cut
- */
+The "normal" is a string like "ToLower" which means the swash
+%utf8::ToLower.
+
+=cut */
UV
-Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special)
+Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
{
- UV uv;
+ UV uv0, uv1;
+ U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
+ STRLEN len = 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 {
+ uv0 = utf8_to_uvchr(p, 0);
+ /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
+ * are necessary in EBCDIC, they are redundant no-ops
+ * in ASCII-ish platforms, and hopefully optimized away. */
+ uv1 = NATIVE_TO_UNI(uv0);
+ uvuni_to_utf8(tmpbuf, uv1);
+
+ if (!*swashp) /* load on-demand */
+ *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
+
+ /* The 0xDF is the only special casing Unicode code point below 0x100. */
+ if (special && (uv1 == 0xDF || uv1 > 0xFF)) {
+ /* It might be "special" (sometimes, but not always,
+ * a multicharacter mapping) */
HV *hv;
- SV *keysv;
- HE *he;
-
- uv = utf8_to_uvchr(p, 0);
-
- 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);
+ SV **svp;
+
+ if ((hv = get_hv(special, FALSE)) &&
+ (svp = hv_fetch(hv, (const char*)tmpbuf, UNISKIP(uv1), FALSE)) &&
+ (*svp)) {
+ char *s;
+
+ s = SvPV(*svp, len);
+ if (len == 1)
+ len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
else {
- /* something in the 0x80..0xFF range */
- ustrp[0] = UTF8_EIGHT_BIT_HI(c);
- ustrp[1] = UTF8_EIGHT_BIT_LO(c);
- *lenp = 2;
+#ifdef EBCDIC
+ /* If we have EBCDIC we need to remap the characters
+ * since any characters in the low 256 are Unicode
+ * code points, not EBCDIC. */
+ U8 *t = (U8*)s, *tend = t + len, *d;
+
+ d = tmpbuf;
+ if (SvUTF8(*svp)) {
+ STRLEN tlen = 0;
+
+ while (t < tend) {
+ UV c = utf8_to_uvchr(t, &tlen);
+ if (tlen > 0) {
+ d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
+ t += tlen;
+ }
+ else
+ break;
+ }
+ }
+ else {
+ while (t < tend) {
+ d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
+ t++;
+ }
+ }
+ len = d - tmpbuf;
+ Copy(tmpbuf, ustrp, len, U8);
+#else
+ Copy(s, ustrp, len, U8);
+#endif
}
- return 0;
}
}
- *lenp = UNISKIP(uv);
- uvuni_to_utf8(ustrp, uv);
- return uv;
+
+ if (!len && *swashp) {
+ UV uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
+
+ if (uv2) {
+ /* It was "normal" (a single character mapping). */
+ UV uv3 = UNI_TO_NATIVE(uv2);
+
+ len = uvchr_to_utf8(ustrp, uv3) - ustrp;
+ }
+ }
+
+ if (!len) /* Neither: just copy. */
+ len = uvchr_to_utf8(ustrp, uv0) - ustrp;
+
+ if (lenp)
+ *lenp = len;
+
+ return len ? utf8_to_uvchr(ustrp, 0) : 0;
}
+/*
+=for apidoc A|UV|to_utf8_upper|U8 *p|U8 *ustrp|STRLEN *lenp
+
+Convert the UTF-8 encoded character at p to its uppercase version and
+store that in UTF-8 in ustrp and its length in bytes in lenp. Note
+that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
+uppercase version may be longer than the original character (up to two
+characters).
+
+The first character of the uppercased version is returned
+(but note, as explained above, that there may be more.)
+
+=cut */
+
UV
Perl_to_utf8_upper(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
{
&PL_utf8_toupper, "ToUpper", "utf8::ToSpecUpper");
}
+/*
+=for apidoc A|UV|to_utf8_title|U8 *p|U8 *ustrp|STRLEN *lenp
+
+Convert the UTF-8 encoded character at p to its titlecase version and
+store that in UTF-8 in ustrp and its length in bytes in lenp. Note
+that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
+titlecase version may be longer than the original character (up to two
+characters).
+
+The first character of the titlecased version is returned
+(but note, as explained above, that there may be more.)
+
+=cut */
+
UV
Perl_to_utf8_title(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
{
&PL_utf8_totitle, "ToTitle", "utf8::ToSpecTitle");
}
+/*
+=for apidoc A|UV|to_utf8_lower|U8 *p|U8 *ustrp|STRLEN *lenp
+
+Convert the UTF-8 encoded character at p to its lowercase version and
+store that in UTF-8 in ustrp and its length in bytes in lenp. Note
+that the ustrp needs to be at least UTF8_MAXLEN_UCLC+1 bytes since the
+lowercase version may be longer than the original character (up to two
+characters).
+
+The first character of the lowercased version is returned
+(but note, as explained above, that there may be more.)
+
+=cut */
+
UV
Perl_to_utf8_lower(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
{
&PL_utf8_tolower, "ToLower", "utf8::ToSpecLower");
}
+/*
+=for apidoc A|UV|to_utf8_fold|U8 *p|U8 *ustrp|STRLEN *lenp
+
+Convert the UTF-8 encoded character at p to its foldcase version and
+store that in UTF-8 in ustrp and its length in bytes in lenp. Note
+that the ustrp needs to be at least UTF8_MAXLEN_FOLD+1 bytes since the
+foldcase version may be longer than the original character (up to
+three characters).
+
+The first character of the foldcased version is returned
+(but note, as explained above, that there may be more.)
+
+=cut */
+
UV
Perl_to_utf8_fold(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp)
{
SV* retval;
SV* tokenbufsv = sv_2mortal(NEWSV(0,0));
dSP;
- HV *stash = gv_stashpvn(pkg, strlen(pkg), FALSE);
+ size_t pkg_len = strlen(pkg);
+ size_t name_len = strlen(name);
+ HV *stash = gv_stashpvn(pkg, pkg_len, 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);
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
+ Nullsv);
if (!SvTRUE(ERRSV))
sv_setsv(ERRSV, errsv_save);
SvREFCNT_dec(errsv_save);
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
EXTEND(SP,5);
- PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
- PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
+ PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len)));
+ PUSHs(sv_2mortal(newSVpvn(name, name_len)));
PUSHs(listsv);
PUSHs(sv_2mortal(newSViv(minbits)));
PUSHs(sv_2mortal(newSViv(none)));
SAVEI32(PL_hints);
PL_hints = 0;
save_re_context();
- if (PL_curcop == &PL_compiling)
+ if (IN_PERL_COMPILETIME) {
/* XXX ought to be handled by lex_start */
+ SAVEI32(PL_in_my);
+ PL_in_my = 0;
sv_setpv(tokenbufsv, PL_tokenbuf);
+ }
errsv_save = newSVsv(ERRSV);
if (call_method("SWASHNEW", G_SCALAR))
retval = newSVsv(*PL_stack_sp--);
SvREFCNT_dec(errsv_save);
LEAVE;
POPSTACK;
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
STRLEN len;
char* pv = SvPV(tokenbufsv, len);
Copy(pv, PL_tokenbuf, len+1, char);
- PL_curcop->op_private = PL_hints;
+ PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
}
- if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
+ if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
+ if (SvPOK(retval))
+ Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
+ retval);
Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
+ }
return retval;
}
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);
+ tmputf8[0] = (U8)UTF8_EIGHT_BIT_HI(c);
+ tmputf8[1] = (U8)UTF8_EIGHT_BIT_LO(c);
ptr = tmputf8;
}
/* Given a UTF-X encoded char 0xAA..0xYY,0xZZ
if (klen == 0)
{
/* If char in invariant then swatch is for all the invariant chars
- * In both UTF-8 and UTF8-MOD that happens to be UTF_CONTINUATION_MARK
+ * In both UTF-8 and UTF-8-MOD that happens to be UTF_CONTINUATION_MARK
*/
needents = UTF_CONTINUATION_MARK;
off = NATIVE_TO_UTF(ptr[klen]);
/* We use utf8n_to_uvuni() as we want an index into
Unicode tables, not a native character number.
*/
- UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, NULL, 0);
+ UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, 0,
+ ckWARN(WARN_UTF8) ?
+ 0 : UTF8_ALLOW_ANY);
SV *errsv_save;
ENTER;
SAVETMPS;
POPSTACK;
FREETMPS;
LEAVE;
- if (PL_curcop == &PL_compiling)
- PL_curcop->op_private = PL_hints;
+ if (IN_PERL_COMPILETIME)
+ PL_curcop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
svp = hv_store(hv, (char*)ptr, klen, retval, 0);
/*
=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
-Adds the UTF8 representation of the Native codepoint C<uv> to the end
+Adds the UTF-8 representation of the Native codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
bytes available. The return value is the pointer to the byte after the
end of the new character. In other words,
U8 *
Perl_uvchr_to_utf8(pTHX_ U8 *d, UV uv)
{
- return Perl_uvuni_to_utf8(aTHX_ d, NATIVE_TO_UNI(uv));
+ return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), 0);
}
+U8 *
+Perl_uvchr_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
+{
+ return Perl_uvuni_to_utf8_flags(aTHX_ d, NATIVE_TO_UNI(uv), flags);
+}
/*
=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
Returns the native character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
length, in bytes, of that character.
Allows length and flags to be passed to low level routine.
=cut
*/
-/* On ASCII machines this is normally a macro but we want a
- real function in case XS code wants it
+/* On ASCII machines this is normally a macro but we want
+ a real function in case XS code wants it
*/
#undef Perl_utf8n_to_uvchr
UV
Build to the scalar dsv a displayable version of the string spv,
length len, the displayable version being at most pvlim bytes long
(if longer, the rest is truncated and "..." will be appended).
-The flags argument is currently unused but available for future extensions.
+
+The flags argument can have UNI_DISPLAY_ISPRINT set to display
+isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
+to display the \\[nrfta\\] as the backslashed versions (like '\n')
+(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
+UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
+UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
+
The pointer to the PV of the dsv is returned.
=cut */
sv_setpvn(dsv, "", 0);
for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
UV u;
+ bool ok = FALSE;
+
if (pvlim && SvCUR(dsv) >= pvlim) {
truncated++;
break;
}
u = utf8_to_uvchr((U8*)s, 0);
- Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
+ if (u < 256) {
+ if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
+ switch (u & 0xFF) {
+ case '\n':
+ Perl_sv_catpvf(aTHX_ dsv, "\\n"); ok = TRUE; break;
+ case '\r':
+ Perl_sv_catpvf(aTHX_ dsv, "\\r"); ok = TRUE; break;
+ case '\t':
+ Perl_sv_catpvf(aTHX_ dsv, "\\t"); ok = TRUE; break;
+ case '\f':
+ Perl_sv_catpvf(aTHX_ dsv, "\\f"); ok = TRUE; break;
+ case '\a':
+ Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break;
+ case '\\':
+ Perl_sv_catpvf(aTHX_ dsv, "\\\\" ); ok = TRUE; break;
+ default: break;
+ }
+ }
+ /* isPRINT() is the locale-blind version. */
+ if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(u & 0xFF)) {
+ Perl_sv_catpvf(aTHX_ dsv, "%c", (char)(u & 0xFF));
+ ok = TRUE;
+ }
+ }
+ if (!ok)
+ Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
}
if (truncated)
sv_catpvn(dsv, "...", 3);
=for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
Build to the scalar dsv a displayable version of the scalar sv,
-he displayable version being at most pvlim bytes long
+the displayable version being at most pvlim bytes long
(if longer, the rest is truncated and "..." will be appended).
-The flags argument is currently unused but available for future extensions.
+
+The flags argument is as in pv_uni_display().
+
The pointer to the PV of the dsv is returned.
=cut */
}
/*
-=for apidoc A|I32|ibcmp_utf8|const char *s1|bool u1|const char *s2|bool u2|register I32 len
+=for apidoc A|I32|ibcmp_utf8|const char *s1|char **pe1|register UV l1|bool u1|const char *s2|char **pe2|register UV l2|bool u2
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.
+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
+circustances. 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 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, bool u1, register I32 len1, const char *s2, bool u2, register I32 len2)
-{
- register U8 *a = (U8*)s1;
- register U8 *b = (U8*)s2;
- register U8 *ae = b + len1;
- register U8 *be = b + len2;
- STRLEN la, lb;
- UV ca, cb;
- STRLEN ulen1, ulen2;
- U8 tmpbuf1[UTF8_MAXLEN_FOLD+1];
- U8 tmpbuf2[UTF8_MAXLEN_FOLD+1];
+Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2)
+{
+ register U8 *p1 = (U8*)s1;
+ register U8 *p2 = (U8*)s2;
+ register U8 *e1 = 0, *f1 = 0, *q1 = 0;
+ register U8 *e2 = 0, *f2 = 0, *q2 = 0;
+ STRLEN n1 = 0, n2 = 0;
+ U8 foldbuf1[UTF8_MAXLEN_FOLD+1];
+ U8 foldbuf2[UTF8_MAXLEN_FOLD+1];
+ U8 natbuf[1+1];
+ STRLEN foldlen1, foldlen2;
+ bool match;
- while (a < ae && b < be) {
- if (u1) {
- if (a + UTF8SKIP(a) > ae)
- break;
- ca = utf8_to_uvchr((U8*)a, &la);
- } else {
- ca = *a;
- la = 1;
- }
- if (u2) {
- if (b + UTF8SKIP(b) > be)
- break;
- cb = utf8_to_uvchr((U8*)b, &lb);
- } else {
- cb = *b;
- lb = 1;
- }
- if (ca != cb) {
+ if (pe1)
+ e1 = *(U8**)pe1;
+ if (e1 == 0 || (l1 && l1 < (UV)(e1 - (U8*)s1)))
+ f1 = (U8*)s1 + l1;
+ if (pe2)
+ e2 = *(U8**)pe2;
+ if (e2 == 0 || (l2 && l2 < (UV)(e2 - (U8*)s2)))
+ f2 = (U8*)s2 + l2;
+
+ 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_uni_fold(NATIVE_TO_UNI(ca), tmpbuf1, &ulen1);
- else
- ulen1 = 1;
+ to_utf8_fold(p1, foldbuf1, &foldlen1);
+ else {
+ natbuf[0] = *p1;
+ to_utf8_fold(natbuf, foldbuf1, &foldlen1);
+ }
+ q1 = foldbuf1;
+ n1 = foldlen1;
+ }
+ if (n2 == 0) {
if (u2)
- to_uni_fold(NATIVE_TO_UNI(cb), tmpbuf2, &ulen2);
- else
- ulen2 = 1;
- if (ulen1 != ulen2
- || (ulen1 == 1 && PL_fold[ca] != PL_fold[cb])
- || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
- return 1; /* mismatch */
+ to_utf8_fold(p2, foldbuf2, &foldlen2);
+ else {
+ natbuf[0] = *p2;
+ to_utf8_fold(natbuf, foldbuf2, &foldlen2);
+ }
+ q2 = foldbuf2;
+ n2 = foldlen2;
}
- a += la;
- b += lb;
+ 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;
+
}
- return a == ae && b == be ? 0 : 1; /* 0 match, 1 mismatch */
+
+ /* 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 */
}
https://perl5.git.perl.org / perl5.git / blobdiff