#include "EXTERN.h"
#define PERL_IN_UTF8_C
#include "perl.h"
-#include "inline_invlist.c"
-#include "charclass_invlists.h"
+#include "invlist_inline.h"
static const char unees[] =
"Malformed UTF-8 character (unexpected end of string)";
*/
/*
-=for apidoc is_ascii_string
+=for apidoc is_invariant_string
-Returns true if the first C<len> bytes of the string C<s> 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.
+Returns true iff the first C<len> bytes of the string C<s> are the same
+regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
+EBCDIC machines). That is, if they are UTF-8 invariant. On ASCII-ish
+machines, all the ASCII characters and only the ASCII characters fit this
+definition. On EBCDIC machines, the ASCII-range characters are invariant, but
+so also are the C1 controls and C<\c?> (which isn't in the ASCII range on
+EBCDIC).
If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
use this option, that C<s> can't have embedded C<NUL> characters and has to
*/
bool
-Perl_is_ascii_string(const U8 *s, STRLEN len)
+Perl_is_invariant_string(const U8 *s, STRLEN len)
{
const U8* const send = s + (len ? len : strlen((const char *)s));
const U8* x = s;
- PERL_ARGS_ASSERT_IS_ASCII_STRING;
+ PERL_ARGS_ASSERT_IS_INVARIANT_STRING;
for (; x < send; ++x) {
if (!UTF8_IS_INVARIANT(*x))
(as opposed to native) code point. Only in very rare circumstances should code
not be using the native code point.
-For details, see the description for L</uvchr_to_utf8_flags>>.
+For details, see the description for L</uvchr_to_utf8_flags>.
=cut
*/
return d;
}
+#ifdef EBCDIC
+ /* Not representable in UTF-EBCDIC */
+ flags |= UNICODE_DISALLOW_FE_FF;
+#endif
+
/* The first problematic code point is the first surrogate */
- if (uv >= UNICODE_SURROGATE_FIRST
+ if ( flags /* It's common to turn off all these */
+ && uv >= UNICODE_SURROGATE_FIRST
&& ckWARN3_d(WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR))
{
if (UNICODE_IS_SURROGATE(uv)) {
if (flags & UNICODE_DISALLOW_SUPER
|| (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_DISALLOW_FE_FF)))
{
+#ifdef EBCDIC
+ Perl_die(aTHX_ "Can't represent character for Ox%"UVXf" on this platform", uv);
+ NOT_REACHED; /* NOTREACHED */
+#endif
return NULL;
}
}
else if (UNICODE_IS_NONCHAR(uv)) {
if (flags & UNICODE_WARN_NONCHAR) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_NONCHAR),
- "Unicode non-character U+%04"UVXf" is illegal for open interchange",
+ "Unicode non-character U+%04"UVXf" is not recommended for open interchange",
uv);
}
if (flags & UNICODE_DISALLOW_NONCHAR) {
=for apidoc uvchr_to_utf8
Adds the UTF-8 representation of the native code point C<uv> to the end
-of the string C<d>; C<d> should have at least C<UNISKIP(uv)+1> (up to
+of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
C<UTF8_MAXBYTES+1>) free bytes available. The return value is the pointer to
the byte after the end of the new character. In other words,
=for apidoc uvchr_to_utf8_flags
Adds the UTF-8 representation of the native code point C<uv> to the end
-of the string C<d>; C<d> should have at least C<UNISKIP(uv)+1> (up to
+of the string C<d>; C<d> should have at least C<UVCHR_SKIP(uv)+1> (up to
C<UTF8_MAXBYTES+1>) free bytes available. The return value is the pointer to
the byte after the end of the new character. In other words,
legal Unicode or are problematic, unless C<flags> contains one or more of the
following flags:
-If C<uv> is a Unicode surrogate code point and UNICODE_WARN_SURROGATE is set,
+If C<uv> is a Unicode surrogate code point and C<UNICODE_WARN_SURROGATE> is set,
the function will raise a warning, provided UTF8 warnings are enabled. If instead
-UNICODE_DISALLOW_SURROGATE is set, the function will fail and return NULL.
+C<UNICODE_DISALLOW_SURROGATE> is set, the function will fail and return NULL.
If both flags are set, the function will both warn and return NULL.
-The UNICODE_WARN_NONCHAR and UNICODE_DISALLOW_NONCHAR flags
+The C<UNICODE_WARN_NONCHAR> and C<UNICODE_DISALLOW_NONCHAR> flags
affect how the function handles a Unicode non-character. And likewise, the
-UNICODE_WARN_SUPER and UNICODE_DISALLOW_SUPER flags affect the handling of
+C<UNICODE_WARN_SUPER> and C<UNICODE_DISALLOW_SUPER> flags affect the handling of
code points that are
above the Unicode maximum of 0x10FFFF. Code points above 0x7FFF_FFFF (which are
even less portable) can be warned and/or disallowed even if other above-Unicode
-code points are accepted, by the UNICODE_WARN_FE_FF and UNICODE_DISALLOW_FE_FF
-flags.
+code points are accepted, by the C<UNICODE_WARN_FE_FF> and
+C<UNICODE_DISALLOW_FE_FF> flags.
-And finally, the flag UNICODE_WARN_ILLEGAL_INTERCHANGE selects all four of the
-above WARN flags; and UNICODE_DISALLOW_ILLEGAL_INTERCHANGE selects all four
-DISALLOW flags.
+And finally, the flag C<UNICODE_WARN_ILLEGAL_INTERCHANGE> selects all four of
+the above WARN flags; and C<UNICODE_DISALLOW_ILLEGAL_INTERCHANGE> selects all
+four DISALLOW flags.
=cut
*/
}
/*
-=for apidoc is_utf8_char_buf
-
-This is identical to the macro L</isUTF8_CHAR>.
-
-=cut */
-
-STRLEN
-Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end)
-{
-
- PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF;
-
- return isUTF8_CHAR(buf, buf_end);
-}
-
-/*
=for apidoc is_utf8_string
Returns true if the first C<len> bytes of string C<s> form a valid
embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
that all characters being ASCII constitute 'a valid UTF-8 string'.
-See also L</is_ascii_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
+See also L</is_invariant_string>(), L</is_utf8_string_loclen>(), and L</is_utf8_string_loc>().
=cut
*/
malformations, the Unicode REPLACEMENT CHARACTER is returned, as these have no
determinable reasonable value.
-The UTF8_CHECK_ONLY flag overrides the behavior when a non-allowed (by other
+The C<UTF8_CHECK_ONLY> flag overrides the behavior when a non-allowed (by other
flags) malformation is found. If this flag is set, the routine assumes that
the caller will raise a warning, and this function will silently just set
C<retlen> to C<-1> (cast to C<STRLEN>) and return zero.
Note that this API requires disambiguation between successful decoding a C<NUL>
-character, and an error return (unless the UTF8_CHECK_ONLY flag is set), as
+character, and an error return (unless the C<UTF8_CHECK_ONLY> flag is set), as
in both cases, 0 is returned. To disambiguate, upon a zero return, see if the
first byte of C<s> is 0 as well. If so, the input was a C<NUL>; if not, the
input had an error.
Unicode non-characters, and code points above the Unicode maximum of 0x10FFFF.
By default these are considered regular code points, but certain situations
warrant special handling for them. If C<flags> contains
-UTF8_DISALLOW_ILLEGAL_INTERCHANGE, all three classes are treated as
-malformations and handled as such. The flags UTF8_DISALLOW_SURROGATE,
-UTF8_DISALLOW_NONCHAR, and UTF8_DISALLOW_SUPER (meaning above the legal Unicode
-maximum) can be set to disallow these categories individually.
-
-The flags UTF8_WARN_ILLEGAL_INTERCHANGE, UTF8_WARN_SURROGATE,
-UTF8_WARN_NONCHAR, and UTF8_WARN_SUPER will cause warning messages to be raised
-for their respective categories, but otherwise the code points are considered
-valid (not malformations). To get a category to both be treated as a
-malformation and raise a warning, specify both the WARN and DISALLOW flags.
+C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, all three classes are treated as
+malformations and handled as such. The flags C<UTF8_DISALLOW_SURROGATE>,
+C<UTF8_DISALLOW_NONCHAR>, and C<UTF8_DISALLOW_SUPER> (meaning above the legal
+Unicode maximum) can be set to disallow these categories individually.
+
+The flags C<UTF8_WARN_ILLEGAL_INTERCHANGE>, C<UTF8_WARN_SURROGATE>,
+C<UTF8_WARN_NONCHAR>, and C<UTF8_WARN_SUPER> will cause warning messages to be
+raised for their respective categories, but otherwise the code points are
+considered valid (not malformations). To get a category to both be treated as
+a malformation and raise a warning, specify both the WARN and DISALLOW flags.
(But note that warnings are not raised if lexically disabled nor if
-UTF8_CHECK_ONLY is also specified.)
+C<UTF8_CHECK_ONLY> is also specified.)
Very large code points (above 0x7FFF_FFFF) are considered more problematic than
the others that are above the Unicode legal maximum. There are several
representable by a UV on ASCII platforms, but not by an IV, which means that
the number of operations that can be performed on them is quite restricted.)
The UTF-8 encoding on ASCII platforms for these large code points begins with a
-byte containing 0xFE or 0xFF. The UTF8_DISALLOW_FE_FF flag will cause them to
+byte containing 0xFE or 0xFF. The C<UTF8_DISALLOW_FE_FF> flag will cause them to
be treated as malformations, while allowing smaller above-Unicode code points.
-(Of course UTF8_DISALLOW_SUPER will treat all above-Unicode code points,
+(Of course C<UTF8_DISALLOW_SUPER> will treat all above-Unicode code points,
including these, as malformations.)
-Similarly, UTF8_WARN_FE_FF acts just like
+Similarly, C<UTF8_WARN_FE_FF> acts just like
the other WARN flags, but applies just to these code points.
All other code points corresponding to Unicode characters, including private
UV
Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
- dVAR;
const U8 * const s0 = s;
U8 overflow_byte = '\0'; /* Save byte in case of overflow */
U8 * send;
if ((flags & (UTF8_WARN_NONCHAR|UTF8_CHECK_ONLY)) == UTF8_WARN_NONCHAR
&& ckWARN_d(WARN_NONCHAR))
{
- sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv));
+ sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv));
pack_warn = packWARN(WARN_NONCHAR);
}
if (flags & UTF8_DISALLOW_NONCHAR) {
* is the label <malformed>.
*/
-malformed:
+ malformed:
if (sv && ckWARN_d(WARN_UTF8)) {
pack_warn = packWARN(WARN_UTF8);
}
-disallowed:
+ disallowed:
if (flags & UTF8_CHECK_ONLY) {
if (retlen)
return 0;
}
-do_warn:
+ do_warn:
if (pack_warn) { /* <pack_warn> was initialized to 0, and changed only
if warnings are to be raised. */
If C<s> does not point to a well-formed UTF-8 character and UTF8 warnings are
enabled, zero is returned and C<*retlen> is set (if C<retlen> isn't
-NULL) to -1. If those warnings are off, the computed value, if well-defined
+C<NULL>) to -1. If those warnings are off, the computed value, if well-defined
(or the Unicode REPLACEMENT CHARACTER if not), is silently returned, and
-C<*retlen> is set (if C<retlen> isn't NULL) so that (S<C<s> + C<*retlen>>) is
+C<*retlen> is set (if C<retlen> isn't C<NULL>) so that (S<C<s> + C<*retlen>>) is
the next possible position in C<s> that could begin a non-malformed character.
See L</utf8n_to_uvchr> for details on when the REPLACEMENT CHARACTER is
returned.
UV uv = *s;
PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
+ PERL_UNUSED_CONTEXT;
if (retlen) {
*retlen = expectlen;
STRLEN
Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
{
- dVAR;
STRLEN len = 0;
PERL_ARGS_ASSERT_UTF8_LENGTH;
*/
U8 *
-Perl_utf8_hop(pTHX_ const U8 *s, I32 off)
+Perl_utf8_hop(const U8 *s, I32 off)
{
PERL_ARGS_ASSERT_UTF8_HOP;
- PERL_UNUSED_CONTEXT;
/* Note: cannot use UTF8_IS_...() too eagerly here since e.g
* the bitops (especially ~) can create illegal UTF-8.
* In other words: in Perl UTF-8 is not just for Unicode. */
PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
- PERL_UNUSED_CONTEXT;
-
while (b < bend && u < uend) {
U8 c = *u++;
if (!UTF8_IS_INVARIANT(c)) {
if (u < uend) {
U8 c1 = *u++;
if (UTF8_IS_CONTINUATION(c1)) {
- c = TWO_BYTE_UTF8_TO_NATIVE(c, c1);
+ c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1);
} else {
Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
"Malformed UTF-8 character "
U8 *d;
PERL_ARGS_ASSERT_UTF8_TO_BYTES;
+ PERL_UNUSED_CONTEXT;
/* ensure valid UTF-8 and chars < 256 before updating string */
while (s < send) {
U8 c = *s++;
if (! UTF8_IS_INVARIANT(c)) {
/* Then it is two-byte encoded */
- c = TWO_BYTE_UTF8_TO_NATIVE(c, *s);
+ c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
s++;
}
*d++ = c;
length. Returns the original string if no conversion occurs, C<len>
is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
0 if C<s> is converted or consisted entirely of characters that are invariant
-in utf8 (i.e., US-ASCII on non-EBCDIC machines).
+in UTF-8 (i.e., US-ASCII on non-EBCDIC machines).
=cut
*/
I32 count = 0;
PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
-
PERL_UNUSED_CONTEXT;
if (!*is_utf8)
return (U8 *)start;
U8 c = *s++;
if (! UTF8_IS_INVARIANT(c)) {
/* Then it is two-byte encoded */
- c = TWO_BYTE_UTF8_TO_NATIVE(c, *s);
+ c = EIGHT_BIT_UTF8_TO_NATIVE(c, *s);
s++;
}
*d++ = c;
#define LAST_HIGH_SURROGATE 0xDBFF
#define FIRST_LOW_SURROGATE 0xDC00
#define LAST_LOW_SURROGATE UNICODE_SURROGATE_LAST
- if (uv >= FIRST_HIGH_SURROGATE && uv <= LAST_HIGH_SURROGATE) {
- if (p >= pend) {
- Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
- } else {
+
+ /* This assumes that most uses will be in the first Unicode plane, not
+ * needing surrogates */
+ if (UNLIKELY(uv >= UNICODE_SURROGATE_FIRST
+ && uv <= UNICODE_SURROGATE_LAST))
+ {
+ if (UNLIKELY(p >= pend) || UNLIKELY(uv > LAST_HIGH_SURROGATE)) {
+ Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
+ }
+ else {
UV low = (p[0] << 8) + p[1];
- p += 2;
- if (low < FIRST_LOW_SURROGATE || low > LAST_LOW_SURROGATE)
+ if ( UNLIKELY(low < FIRST_LOW_SURROGATE)
+ || UNLIKELY(low > LAST_LOW_SURROGATE))
+ {
Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
+ }
+ p += 2;
uv = ((uv - FIRST_HIGH_SURROGATE) << 10)
+ (low - FIRST_LOW_SURROGATE) + 0x10000;
}
- } else if (uv >= FIRST_LOW_SURROGATE && uv <= LAST_LOW_SURROGATE) {
- Perl_croak(aTHX_ "Malformed UTF-16 surrogate");
}
#ifdef EBCDIC
d = uvoffuni_to_utf8_flags(d, uv, 0);
bool
Perl__is_utf8_idstart(pTHX_ const U8 *p)
{
- dVAR;
PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
if (*p == '_')
Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_or_s)
{
/* We have the latin1-range values compiled into the core, so just use
- * those, converting the result to utf8. The only difference between upper
+ * those, converting the result to UTF-8. The only difference between upper
* and title case in this range is that LATIN_SMALL_LETTER_SHARP_S is
* either "SS" or "Ss". Which one to use is passed into the routine in
* 'S_or_s' to avoid a test */
case MICRO_SIGN:
converted = GREEK_CAPITAL_LETTER_MU;
break;
+#if UNICODE_MAJOR_VERSION > 2 \
+ || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
+ && UNICODE_DOT_DOT_VERSION >= 8)
case LATIN_SMALL_LETTER_SHARP_S:
*(p)++ = 'S';
*p = S_or_s;
*lenp = 2;
return 'S';
+#endif
default:
Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS);
- /* NOTREACHED */
- assert(0);
+ NOT_REACHED; /* NOTREACHED */
}
}
UV
Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- dVAR;
-
/* Convert the Unicode character whose ordinal is <c> to its uppercase
* version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
* Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
UV
Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- dVAR;
-
PERL_ARGS_ASSERT_TO_UNI_TITLE;
if (c < 256) {
}
STATIC U8
-S_to_lower_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp)
+S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp)
{
/* We have the latin1-range values compiled into the core, so just use
- * those, converting the result to utf8. Since the result is always just
+ * those, converting the result to UTF-8. Since the result is always just
* one character, we allow <p> to be NULL */
U8 converted = toLOWER_LATIN1(c);
*lenp = 1;
}
else {
- *p = UTF8_TWO_BYTE_HI(converted);
- *(p+1) = UTF8_TWO_BYTE_LO(converted);
+ /* Result is known to always be < 256, so can use the EIGHT_BIT
+ * macros */
+ *p = UTF8_EIGHT_BIT_HI(converted);
+ *(p+1) = UTF8_EIGHT_BIT_LO(converted);
*lenp = 2;
}
}
UV
Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- dVAR;
-
PERL_ARGS_ASSERT_TO_UNI_LOWER;
if (c < 256) {
UV converted;
PERL_ARGS_ASSERT__TO_FOLD_LATIN1;
+ PERL_UNUSED_CONTEXT;
assert (! (flags & FOLD_FLAGS_LOCALE));
if (c == MICRO_SIGN) {
converted = GREEK_SMALL_LETTER_MU;
}
+#if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
+ || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
+ || UNICODE_DOT_DOT_VERSION > 0)
else if ((flags & FOLD_FLAGS_FULL) && c == LATIN_SMALL_LETTER_SHARP_S) {
/* If can't cross 127/128 boundary, can't return "ss"; instead return
return 's';
}
}
+#endif
else { /* In this range the fold of all other characters is their lower
case */
converted = toLOWER_LATIN1(c);
PERL_ARGS_ASSERT__TO_UNI_FOLD_FLAGS;
- /* Tread a UTF-8 locale as not being in locale at all */
- if (IN_UTF8_CTYPE_LOCALE) {
- flags &= ~FOLD_FLAGS_LOCALE;
+ if (flags & FOLD_FLAGS_LOCALE) {
+ /* Treat a UTF-8 locale as not being in locale at all */
+ if (IN_UTF8_CTYPE_LOCALE) {
+ flags &= ~FOLD_FLAGS_LOCALE;
+ }
+ else {
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
+ goto needs_full_generality;
+ }
}
if (c < 256) {
- UV result = _to_fold_latin1((U8) c, p, lenp,
+ return _to_fold_latin1((U8) c, p, lenp,
flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
- /* It is illegal for the fold to cross the 255/256 boundary under
- * locale; in this case return the original */
- return (result > 256 && flags & FOLD_FLAGS_LOCALE)
- ? c
- : result;
}
- /* If no special needs, just use the macro */
+ /* Here, above 255. If no special needs, just use the macro */
if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) {
uvchr_to_utf8(p, c);
return CALL_FOLD_CASE(p, p, lenp, flags & FOLD_FLAGS_FULL);
else { /* Otherwise, _to_utf8_fold_flags has the intelligence to deal with
the special flags. */
U8 utf8_c[UTF8_MAXBYTES + 1];
+
+ needs_full_generality:
uvchr_to_utf8(utf8_c, c);
return _to_utf8_fold_flags(utf8_c, p, lenp, flags);
}
* have been checked before this call for mal-formedness enough to assure
* that. */
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_COMMON;
/* The API should have included a length for the UTF-8 character in <p>,
bool
Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT__IS_UTF8_FOO;
assert(classnum < _FIRST_NON_SWASH_CC);
bool
Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
{
- dVAR;
SV* invlist = NULL;
PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
if (! PL_utf8_perl_idstart) {
invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
}
- return is_utf8_common(p, &PL_utf8_perl_idstart, "", invlist);
+ return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart", invlist);
}
bool
Perl__is_utf8_xidstart(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
if (*p == '_')
bool
Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
{
- dVAR;
SV* invlist = NULL;
PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT;
if (! PL_utf8_perl_idcont) {
invlist = _new_invlist_C_array(_Perl_IDCont_invlist);
}
- return is_utf8_common(p, &PL_utf8_perl_idcont, "", invlist);
+ return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont", invlist);
}
bool
Perl__is_utf8_idcont(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT__IS_UTF8_IDCONT;
return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL);
bool
Perl__is_utf8_xidcont(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT__IS_UTF8_XIDCONT;
return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL);
bool
Perl__is_utf8_mark(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT__IS_UTF8_MARK;
return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL);
C<swashp> is a pointer to the swash to use.
Both the special and normal mappings are stored in F<lib/unicore/To/Foo.pl>,
-and loaded by SWASHNEW, using F<lib/utf8_heavy.pl>. C<special> (usually,
+and loaded by C<SWASHNEW>, using F<lib/utf8_heavy.pl>. C<special> (usually,
but not always, a multicharacter mapping), is tried first.
C<special> is a string, normally C<NULL> or C<"">. C<NULL> means to not use
than these two are treated as the name of the hash containing the special
mappings, like C<"utf8::ToSpecLower">.
-C<normal> is a string like "ToLower" which means the swash
-%utf8::ToLower.
+C<normal> is a string like C<"ToLower"> which means the swash
+C<%utf8::ToLower>.
=cut */
Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
SV **swashp, const char *normal, const char *special)
{
- dVAR;
STRLEN len = 0;
const UV uv1 = valid_utf8_to_uvchr(p, NULL);
}
if (hv
- && (svp = hv_fetch(hv, (const char*)p, UNISKIP(uv1), FALSE))
+ && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE))
&& (*svp))
{
const char *s;
}
if (!len && *swashp) {
- const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is utf8 */);
+ const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */);
if (uv2) {
/* It was "normal" (a single character mapping). */
STATIC UV
S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
{
- /* This is called when changing the case of a utf8-encoded character above
+ /* This is called when changing the case of a UTF-8-encoded character above
* the Latin1 range, and the operation is in a non-UTF-8 locale. If the
* result contains a character that crosses the 255/256 boundary, disallow
* the change, and return the original code point. See L<perlfunc/lc> for
s += UTF8SKIP(s);
}
- /* Here, no characters crossed, result is ok as-is */
+ /* Here, no characters crossed, result is ok as-is, but we warn. */
+ _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(p, p + UTF8SKIP(p));
return result;
}
-bad_crossing:
+ bad_crossing:
/* Failed, have to return the original */
original = valid_utf8_to_uvchr(p, lenp);
+
+ /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Can't do %s(\"\\x{%"UVXf"}\") on non-UTF-8 locale; "
+ "resolved to \"\\x{%"UVXf"}\".",
+ OP_DESC(PL_op),
+ original,
+ original);
Copy(p, ustrp, *lenp, char);
return original;
}
UV
Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags)
{
- dVAR;
-
UV result;
PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS;
- if (flags && IN_UTF8_CTYPE_LOCALE) {
- flags = FALSE;
+ if (flags) {
+ /* Treat a UTF-8 locale as not being in locale at all */
+ if (IN_UTF8_CTYPE_LOCALE) {
+ flags = FALSE;
+ }
+ else {
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
+ }
}
if (UTF8_IS_INVARIANT(*p)) {
}
else if UTF8_IS_DOWNGRADEABLE_START(*p) {
if (flags) {
- U8 c = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
+ U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
result = toUPPER_LC(c);
}
else {
- return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)),
+ return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
ustrp, lenp, 'S');
}
}
- else { /* utf8, ord above 255 */
+ else { /* UTF-8, ord above 255 */
result = CALL_UPPER_CASE(p, ustrp, lenp);
if (flags) {
return result;
}
- /* Here, used locale rules. Convert back to utf8 */
+ /* Here, used locale rules. Convert back to UTF-8 */
if (UTF8_IS_INVARIANT(result)) {
*ustrp = (U8) result;
*lenp = 1;
UV
Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags)
{
- dVAR;
-
UV result;
PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS;
- if (flags && IN_UTF8_CTYPE_LOCALE) {
- flags = FALSE;
+ if (flags) {
+ /* Treat a UTF-8 locale as not being in locale at all */
+ if (IN_UTF8_CTYPE_LOCALE) {
+ flags = FALSE;
+ }
+ else {
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
+ }
}
if (UTF8_IS_INVARIANT(*p)) {
}
else if UTF8_IS_DOWNGRADEABLE_START(*p) {
if (flags) {
- U8 c = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
+ U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
result = toUPPER_LC(c);
}
else {
- return _to_upper_title_latin1(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)),
+ return _to_upper_title_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
ustrp, lenp, 's');
}
}
- else { /* utf8, ord above 255 */
+ else { /* UTF-8, ord above 255 */
result = CALL_TITLE_CASE(p, ustrp, lenp);
if (flags) {
return result;
}
- /* Here, used locale rules. Convert back to utf8 */
+ /* Here, used locale rules. Convert back to UTF-8 */
if (UTF8_IS_INVARIANT(result)) {
*ustrp = (U8) result;
*lenp = 1;
{
UV result;
- dVAR;
-
PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
- if (flags && IN_UTF8_CTYPE_LOCALE) {
- flags = FALSE;
+ if (flags) {
+ /* Treat a UTF-8 locale as not being in locale at all */
+ if (IN_UTF8_CTYPE_LOCALE) {
+ flags = FALSE;
+ }
+ else {
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
+ }
}
if (UTF8_IS_INVARIANT(*p)) {
}
else if UTF8_IS_DOWNGRADEABLE_START(*p) {
if (flags) {
- U8 c = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
+ U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
result = toLOWER_LC(c);
}
else {
- return to_lower_latin1(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)),
+ return to_lower_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
ustrp, lenp);
}
}
- else { /* utf8, ord above 255 */
+ else { /* UTF-8, ord above 255 */
result = CALL_LOWER_CASE(p, ustrp, lenp);
if (flags) {
return result;
}
- /* Here, used locale rules. Convert back to utf8 */
+ /* Here, used locale rules. Convert back to UTF-8 */
if (UTF8_IS_INVARIANT(result)) {
*ustrp = (U8) result;
*lenp = 1;
UV
Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags)
{
- dVAR;
-
UV result;
PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS;
assert(p != ustrp); /* Otherwise overwrites */
- if (flags & FOLD_FLAGS_LOCALE && IN_UTF8_CTYPE_LOCALE) {
- flags &= ~FOLD_FLAGS_LOCALE;
+ if (flags & FOLD_FLAGS_LOCALE) {
+ /* Treat a UTF-8 locale as not being in locale at all */
+ if (IN_UTF8_CTYPE_LOCALE) {
+ flags &= ~FOLD_FLAGS_LOCALE;
+ }
+ else {
+ _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
+ }
}
if (UTF8_IS_INVARIANT(*p)) {
}
else if UTF8_IS_DOWNGRADEABLE_START(*p) {
if (flags & FOLD_FLAGS_LOCALE) {
- U8 c = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
+ U8 c = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
result = toFOLD_LC(c);
}
else {
- return _to_fold_latin1(TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1)),
+ return _to_fold_latin1(EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1)),
ustrp, lenp,
flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII));
}
}
- else { /* utf8, ord above 255 */
+ else { /* UTF-8, ord above 255 */
result = CALL_FOLD_CASE(p, ustrp, lenp, flags & FOLD_FLAGS_FULL);
if (flags & FOLD_FLAGS_LOCALE) {
+# define LONG_S_T LATIN_SMALL_LIGATURE_LONG_S_T_UTF8
+ const unsigned int long_s_t_len = sizeof(LONG_S_T) - 1;
+
+# ifdef LATIN_CAPITAL_LETTER_SHARP_S_UTF8
+# define CAP_SHARP_S LATIN_CAPITAL_LETTER_SHARP_S_UTF8
+
+ const unsigned int cap_sharp_s_len = sizeof(CAP_SHARP_S) - 1;
+
/* Special case these two characters, as what normally gets
* returned under locale doesn't work */
- if (UTF8SKIP(p) == sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1
- && memEQ((char *) p, LATIN_CAPITAL_LETTER_SHARP_S_UTF8,
- sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1))
+ if (UTF8SKIP(p) == cap_sharp_s_len
+ && memEQ((char *) p, CAP_SHARP_S, cap_sharp_s_len))
{
+ /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Can't do fc(\"\\x{1E9E}\") on non-UTF-8 locale; "
+ "resolved to \"\\x{17F}\\x{17F}\".");
goto return_long_s;
}
- else if (UTF8SKIP(p) == sizeof(LATIN_SMALL_LIGATURE_LONG_S_T) - 1
- && memEQ((char *) p, LATIN_SMALL_LIGATURE_LONG_S_T_UTF8,
- sizeof(LATIN_SMALL_LIGATURE_LONG_S_T_UTF8) - 1))
+ else
+#endif
+ if (UTF8SKIP(p) == long_s_t_len
+ && memEQ((char *) p, LONG_S_T, long_s_t_len))
{
+ /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Can't do fc(\"\\x{FB05}\") on non-UTF-8 locale; "
+ "resolved to \"\\x{FB06}\".");
goto return_ligature_st;
}
+
+#if UNICODE_MAJOR_VERSION == 3 \
+ && UNICODE_DOT_VERSION == 0 \
+ && UNICODE_DOT_DOT_VERSION == 1
+# define DOTTED_I LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE_UTF8
+
+ /* And special case this on this Unicode version only, for the same
+ * reaons the other two are special cased. They would cross the
+ * 255/256 boundary which is forbidden under /l, and so the code
+ * wouldn't catch that they are equivalent (which they are only in
+ * this release) */
+ else if (UTF8SKIP(p) == sizeof(DOTTED_I) - 1
+ && memEQ((char *) p, DOTTED_I, sizeof(DOTTED_I) - 1))
+ {
+ /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Can't do fc(\"\\x{0130}\") on non-UTF-8 locale; "
+ "resolved to \"\\x{0131}\".");
+ goto return_dotless_i;
+ }
+#endif
+
return check_locale_boundary_crossing(p, result, ustrp, lenp);
}
else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
return result;
}
else {
- /* This is called when changing the case of a utf8-encoded
+ /* This is called when changing the case of a UTF-8-encoded
* character above the ASCII range, and the result should not
* contain an ASCII character. */
/* But in these instances, there is an alternative we can
* return that is valid */
- if (original == LATIN_CAPITAL_LETTER_SHARP_S
- || original == LATIN_SMALL_LETTER_SHARP_S)
- {
+ if (original == LATIN_SMALL_LETTER_SHARP_S
+#ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
+ || original == LATIN_CAPITAL_LETTER_SHARP_S
+#endif
+ ) {
goto return_long_s;
}
else if (original == LATIN_SMALL_LIGATURE_LONG_S_T) {
goto return_ligature_st;
}
+#if UNICODE_MAJOR_VERSION == 3 \
+ && UNICODE_DOT_VERSION == 0 \
+ && UNICODE_DOT_DOT_VERSION == 1
+
+ else if (original == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
+ goto return_dotless_i;
+ }
+#endif
Copy(p, ustrp, *lenp, char);
return original;
}
}
}
- /* Here, used locale rules. Convert back to utf8 */
+ /* Here, used locale rules. Convert back to UTF-8 */
if (UTF8_IS_INVARIANT(result)) {
*ustrp = (U8) result;
*lenp = 1;
*lenp = sizeof(LATIN_SMALL_LIGATURE_ST_UTF8) - 1;
Copy(LATIN_SMALL_LIGATURE_ST_UTF8, ustrp, *lenp, U8);
return LATIN_SMALL_LIGATURE_ST;
+
+#if UNICODE_MAJOR_VERSION == 3 \
+ && UNICODE_DOT_VERSION == 0 \
+ && UNICODE_DOT_DOT_VERSION == 1
+
+ return_dotless_i:
+ *lenp = sizeof(LATIN_SMALL_LETTER_DOTLESS_I_UTF8) - 1;
+ Copy(LATIN_SMALL_LETTER_DOTLESS_I_UTF8, ustrp, *lenp, U8);
+ return LATIN_SMALL_LETTER_DOTLESS_I;
+
+#endif
+
}
/* Note:
SV*
Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
{
+
+ /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST
+ * use the following define */
+
+#define CORE_SWASH_INIT_RETURN(x) \
+ PL_curpm= old_PL_curpm; \
+ return x
+
/* Initialize and return a swash, creating it if necessary. It does this
* by calling utf8_heavy.pl in the general case. The returned value may be
* the swash's inversion list instead if the input parameters allow it.
*
* <invlist> is only valid for binary properties */
- dVAR;
+ PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
+
SV* retval = &PL_sv_undef;
HV* swash_hv = NULL;
const int invlist_swash_boundary =
assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
assert(! invlist || minbits == 1);
+ PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the regex
+ that triggered the swash init and the swash init perl logic itself.
+ See perl #122747 */
+
/* If data was passed in to go out to utf8_heavy to find the swash of, do
* so */
if (listsv != &PL_sv_undef || strNE(name, "")) {
if (PL_parser && PL_parser->error_count)
SAVEI8(PL_parser->error_count), PL_parser->error_count = 0;
method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
- if (!method) { /* demand load utf8 */
+ if (!method) { /* demand load UTF-8 */
ENTER;
if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
GvSV(PL_errgv) = NULL;
+#ifndef NO_TAINT_SUPPORT
/* It is assumed that callers of this routine are not passing in
* any user derived data. */
/* Need to do this after save_re_context() as it will set
* PL_tainted to 1 while saving $1 etc (see the code after getrx:
* in Perl_magic_get). Even line to create errsv_save can turn on
* PL_tainted. */
-#ifndef NO_TAINT_SUPPORT
SAVEBOOL(TAINT_get);
TAINT_NOT;
#endif
/* If caller wants to handle missing properties, let them */
if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
- return NULL;
+ CORE_SWASH_INIT_RETURN(NULL);
}
Perl_croak(aTHX_
"Can't find Unicode property definition \"%"SVf"\"",
SVfARG(retval));
- /* NOTREACHED */
- NOT_REACHED;
+ NOT_REACHED; /* NOTREACHED */
}
} /* End of calling the module to find the swash */
}
}
- return retval;
+ CORE_SWASH_INIT_RETURN(retval);
+#undef CORE_SWASH_INIT_RETURN
}
/* Note:
* Returns the value of property/mapping C<swash> for the first character
* of the string C<ptr>. If C<do_utf8> is true, the string C<ptr> is
- * assumed to be in well-formed utf8. If C<do_utf8> is false, the string C<ptr>
+ * assumed to be in well-formed UTF-8. If C<do_utf8> is false, the string C<ptr>
* is assumed to be in native 8-bit encoding. Caches the swatch in C<swash>.
*
* A "swash" is a hash which contains initially the keys/values set up by
UV
Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
{
- dVAR;
HV *const hv = MUTABLE_HV(SvRV(swash));
U32 klen;
U32 off;
else if (UTF8_IS_DOWNGRADEABLE_START(c)) {
klen = 0;
needents = 256;
- off = TWO_BYTE_UTF8_TO_NATIVE(c, *(ptr + 1));
+ off = EIGHT_BIT_UTF8_TO_NATIVE(c, *(ptr + 1));
}
else {
klen = UTF8SKIP(ptr) - 1;
}
/*
- * This single-entry cache saves about 1/3 of the utf8 overhead in test
+ * This single-entry cache saves about 1/3 of the UTF-8 overhead in test
* suite. (That is, only 7-8% overall over just a hash cache. Still,
* it's nothing to sniff at.) Pity we usually come through at least
* two function calls to get here...
* 004C 006C
* 212A 006B
*
- * The returned hash would have two keys, the utf8 for 006B and the utf8 for
+ * The returned hash would have two keys, the UTF-8 for 006B and the UTF-8 for
* 006C. The value for each key is an array. For 006C, the array would
- * have 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.
+ * have two elements, the UTF-8 for itself, and for 004C. For 006B, there
+ * would be three elements in its array, the UTF-8 for 006B, 004B and 212A.
*
* Note that there are no elements in the hash for 004B, 004C, 212A. The
* keys are only code points that are folded-to, so it isn't a full closure.
*
* The specials hash can be extra code points, and most likely consists of
* maps from single code points to multiple ones (each expressed as a string
- * of utf8 characters). This function currently returns only 1-1 mappings.
+ * of UTF-8 characters). This function currently returns only 1-1 mappings.
* However consider this possible input in the specials hash:
* "\xEF\xAC\x85" => "\x{0073}\x{0074}", # U+FB05 => 0073 0074
* "\xEF\xAC\x86" => "\x{0073}\x{0074}", # U+FB06 => 0073 0074
* currently handle. But it also means that FB05 and FB06 are equivalent in
* a 1-1 mapping which we should handle, and this relationship may not be in
* the main table. Therefore this function examines all the multi-char
- * sequences and adds the 1-1 mappings that come out of that. */
+ * sequences and adds the 1-1 mappings that come out of that.
+ *
+ * XXX This function was originally intended to be multipurpose, but its
+ * only use is quite likely to remain for constructing the inversion of
+ * the CaseFolding (//i) property. If it were more general purpose for
+ * regex patterns, it would have to do the FB05/FB06 game for simple folds,
+ * because certain folds are prohibited under /iaa and /il. As an example,
+ * in Unicode 3.0.1 both U+0130 and U+0131 fold to 'i', and hence are both
+ * equivalent under /i. But under /iaa and /il, the folds to 'i' are
+ * prohibited, so we would not figure out that they fold to each other.
+ * Code could be written to automatically figure this out, similar to the
+ * code that does this for multi-character folds, but this is the only case
+ * where something like this is ever likely to happen, as all the single
+ * char folds to The 0-255 range are now quite settled. Instead there is a
+ * little special code that is compiled only for this Unicode version. This
+ * is smaller and didn't require much coding time to do. But this makes
+ * this routine strongly tied to being used just for CaseFolding. If ever
+ * it should be generalized, this would have to be fixed */
U8 *l, *lend;
STRLEN lcur;
hv_iterinit(specials_hv);
- /* The keys are the characters (in utf8) that map to the corresponding
- * utf8 string value. Iterate through the list creating the inverse
+ /* The keys are the characters (in UTF-8) that map to the corresponding
+ * UTF-8 string value. Iterate through the list creating the inverse
* list. */
while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
SV** listp;
/*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", valid_utf8_to_uvchr((U8*) char_from, 0), valid_utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
/* Each key in the inverse list is a mapped-to value, and the key's
- * hash value is a list of the strings (each in utf8) that map to
+ * hash value is a list of the strings (each in UTF-8) that map to
* it. Those strings are all one character long */
if ((listp = hv_fetch(specials_inverse,
SvPVX(sv_to),
} /* End of specials */
/* read $swash->{LIST} */
+
+#if UNICODE_MAJOR_VERSION == 3 \
+ && UNICODE_DOT_VERSION == 0 \
+ && UNICODE_DOT_DOT_VERSION == 1
+
+ /* For this version only U+130 and U+131 are equivalent under qr//i. Add a
+ * rule so that things work under /iaa and /il */
+
+ SV * mod_listsv = sv_mortalcopy(*listsvp);
+ sv_catpv(mod_listsv, "130\t130\t131\n");
+ l = (U8*)SvPV(mod_listsv, lcur);
+
+#else
+
l = (U8*)SvPV(*listsvp, lcur);
+
+#endif
+
lend = l + lcur;
/* Go through each input line */
lend = l + lcur;
if (*l == 'V') { /* Inversion list format */
- char *after_strtol = (char *) lend;
+ const char *after_atou = (char *) lend;
UV element0;
UV* other_elements_ptr;
/* The first number is a count of the rest */
l++;
- elements = Strtoul((char *)l, &after_strtol, 10);
+ if (!grok_atoUV((const char *)l, &elements, &after_atou)) {
+ Perl_croak(aTHX_ "panic: Expecting a valid count of elements at start of inversion list");
+ }
if (elements == 0) {
invlist = _new_invlist(0);
}
else {
- l = (U8 *) after_strtol;
+ while (isSPACE(*l)) l++;
+ l = (U8 *) after_atou;
/* Get the 0th element, which is needed to setup the inversion list */
- element0 = (UV) Strtoul((char *)l, &after_strtol, 10);
- l = (U8 *) after_strtol;
+ while (isSPACE(*l)) l++;
+ if (!grok_atoUV((const char *)l, &element0, &after_atou)) {
+ Perl_croak(aTHX_ "panic: Expecting a valid 0th element for inversion list");
+ }
+ l = (U8 *) after_atou;
invlist = _setup_canned_invlist(elements, element0, &other_elements_ptr);
elements--;
if (l > lend) {
Perl_croak(aTHX_ "panic: Expecting %"UVuf" more elements than available", elements);
}
- *other_elements_ptr++ = (UV) Strtoul((char *)l, &after_strtol, 10);
- l = (U8 *) after_strtol;
+ while (isSPACE(*l)) l++;
+ if (!grok_atoUV((const char *)l, other_elements_ptr++, &after_atou)) {
+ Perl_croak(aTHX_ "panic: Expecting a valid element in inversion list");
+ }
+ l = (U8 *) after_atou;
}
}
}
"%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print");
return FALSE;
}
- if (UNLIKELY(*s >= UTF8_FIRST_PROBLEMATIC_CODE_POINT_FIRST_BYTE)) {
+ if (UNLIKELY(isUTF8_POSSIBLY_PROBLEMATIC(*s))) {
STRLEN char_len;
- if (UTF8_IS_SUPER(s)) {
+ if (UTF8_IS_SUPER(s, e)) {
if (ckWARN_d(WARN_NON_UNICODE)) {
UV uv = utf8_to_uvchr_buf(s, e, &char_len);
Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
ok = FALSE;
}
}
- else if (UTF8_IS_SURROGATE(s)) {
+ else if (UTF8_IS_SURROGATE(s, e)) {
if (ckWARN_d(WARN_SURROGATE)) {
UV uv = utf8_to_uvchr_buf(s, e, &char_len);
Perl_warner(aTHX_ packWARN(WARN_SURROGATE),
ok = FALSE;
}
}
- else if
- ((UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC(s))
- && (ckWARN_d(WARN_NONCHAR)))
- {
+ else if ((UTF8_IS_NONCHAR(s, e)) && (ckWARN_d(WARN_NONCHAR))) {
UV uv = utf8_to_uvchr_buf(s, e, &char_len);
Perl_warner(aTHX_ packWARN(WARN_NONCHAR),
- "Unicode non-character U+%04"UVXf" is illegal for open interchange", uv);
+ "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv);
ok = FALSE;
}
}
Build to the scalar C<dsv> a displayable version of the string C<spv>,
length C<len>, the displayable version being at most C<pvlim> bytes long
-(if longer, the rest is truncated and "..." will be appended).
+(if longer, the rest is truncated and C<"..."> will be appended).
-The C<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 C<flags> argument can have C<UNI_DISPLAY_ISPRINT> set to display
+C<isPRINT()>able characters as themselves, C<UNI_DISPLAY_BACKSLASH>
+to display the C<\\[nrfta\\]> as the backslashed versions (like C<"\n">)
+(C<UNI_DISPLAY_BACKSLASH> is preferred over C<UNI_DISPLAY_ISPRINT> for C<"\\">).
+C<UNI_DISPLAY_QQ> (and its alias C<UNI_DISPLAY_REGEX>) have both
+C<UNI_DISPLAY_BACKSLASH> and C<UNI_DISPLAY_ISPRINT> turned on.
The pointer to the PV of the C<dsv> is returned.
+See also L</sv_uni_display>.
+
=cut */
char *
Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
scanning won't continue past that goal. Correspondingly for C<l2> with respect to
C<s2>.
-If C<pe1> is non-NULL and the pointer it points to is not NULL, that pointer is
+If C<pe1> is non-C<NULL> and the pointer it points to is not C<NULL>, that pointer is
considered an end pointer to the position 1 byte past the maximum point
in C<s1> beyond which scanning will not continue under any circumstances.
(This routine assumes that UTF-8 encoded input strings are not malformed;
characters, all of them must be matched (see tr21 reference below for
'folding').
-Upon a successful match, if C<pe1> is non-NULL,
+Upon a successful match, if C<pe1> is non-C<NULL>,
it will be set to point to the beginning of the I<next> character of C<s1>
beyond what was matched. Correspondingly for C<pe2> and C<s2>.
* FOLDEQ_LOCALE is set iff the rules from the current underlying
* locale are to be used.
* FOLDEQ_S1_ALREADY_FOLDED s1 has already been folded before calling this
- * routine. This allows that step to be skipped.
+ * routine. This allows that step to be skipped.
+ * Currently, this requires s1 to be encoded as UTF-8
+ * (u1 must be true), which is asserted for.
+ * FOLDEQ_S1_FOLDS_SANE With either NOMIX_ASCII or LOCALE, no folds may
+ * cross certain boundaries. Hence, the caller should
+ * let this function do the folding instead of
+ * pre-folding. This code contains an assertion to
+ * that effect. However, if the caller knows what
+ * it's doing, it can pass this flag to indicate that,
+ * and the assertion is skipped.
* FOLDEQ_S2_ALREADY_FOLDED Similarly.
+ * FOLDEQ_S2_FOLDS_SANE
*/
I32
Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2, U32 flags)
{
- dVAR;
const U8 *p1 = (const U8*)s1; /* Point to current char */
const U8 *p2 = (const U8*)s2;
const U8 *g1 = NULL; /* goal for s1 */
STRLEN n1 = 0, n2 = 0; /* Number of bytes in current char */
U8 foldbuf1[UTF8_MAXBYTES_CASE+1];
U8 foldbuf2[UTF8_MAXBYTES_CASE+1];
+ U8 flags_for_folder = FOLD_FLAGS_FULL;
PERL_ARGS_ASSERT_FOLDEQ_UTF8_FLAGS;
assert( ! ((flags & (FOLDEQ_UTF8_NOMIX_ASCII | FOLDEQ_LOCALE))
- && (flags & (FOLDEQ_S1_ALREADY_FOLDED | FOLDEQ_S2_ALREADY_FOLDED))));
+ && (((flags & FOLDEQ_S1_ALREADY_FOLDED)
+ && !(flags & FOLDEQ_S1_FOLDS_SANE))
+ || ((flags & FOLDEQ_S2_ALREADY_FOLDED)
+ && !(flags & FOLDEQ_S2_FOLDS_SANE)))));
/* The algorithm is to trial the folds without regard to the flags on
* the first line of the above assert(), and then see if the result
* violates them. This means that the inputs can't be pre-folded to a
* and /iaa matches are most likely to involve code points 0-255, and this
* function only under rare conditions gets called for 0-255. */
- if (IN_UTF8_CTYPE_LOCALE) {
- flags &= ~FOLDEQ_LOCALE;
+ if (flags & FOLDEQ_LOCALE) {
+ if (IN_UTF8_CTYPE_LOCALE) {
+ flags &= ~FOLDEQ_LOCALE;
+ }
+ else {
+ flags_for_folder |= FOLD_FLAGS_LOCALE;
+ }
}
if (pe1) {
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. (exception: locale rules just get the
- * character to a single byte) */
+ * and the length of the fold. */
if (n1 == 0) {
if (flags & FOLDEQ_S1_ALREADY_FOLDED) {
f1 = (U8 *) p1;
+ assert(u1);
n1 = UTF8SKIP(f1);
}
else {
- /* If in locale matching, we use two sets of rules, depending
- * on if the code point is above or below 255. Here, we test
- * for and handle locale rules */
- if ((flags & FOLDEQ_LOCALE)
- && (! u1 || ! UTF8_IS_ABOVE_LATIN1(*p1)))
- {
- /* There is no mixing of code points above and below 255. */
- if (u2 && UTF8_IS_ABOVE_LATIN1(*p2)) {
- return 0;
- }
-
- /* We handle locale rules by converting, if necessary, the
- * code point to a single byte. */
- if (! u1 || UTF8_IS_INVARIANT(*p1)) {
- *foldbuf1 = *p1;
- }
- else {
- *foldbuf1 = TWO_BYTE_UTF8_TO_NATIVE(*p1, *(p1 + 1));
- }
- n1 = 1;
- }
- else if (isASCII(*p1)) { /* Note, that here won't be both
- ASCII and using locale rules */
-
- /* If trying to mix non- with ASCII, and not supposed to,
- * fail */
- if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
- return 0;
- }
- n1 = 1;
- *foldbuf1 = toFOLD(*p1);
- }
- else if (u1) {
- to_utf8_fold(p1, foldbuf1, &n1);
- }
- else { /* Not utf8, get utf8 fold */
- to_uni_fold(*p1, foldbuf1, &n1);
- }
- f1 = foldbuf1;
- }
+ if (isASCII(*p1) && ! (flags & FOLDEQ_LOCALE)) {
+
+ /* We have to forbid mixing ASCII with non-ASCII if the
+ * flags so indicate. And, we can short circuit having to
+ * call the general functions for this common ASCII case,
+ * all of whose non-locale folds are also ASCII, and hence
+ * UTF-8 invariants, so the UTF8ness of the strings is not
+ * relevant. */
+ if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p2)) {
+ return 0;
+ }
+ n1 = 1;
+ *foldbuf1 = toFOLD(*p1);
+ }
+ else if (u1) {
+ _to_utf8_fold_flags(p1, foldbuf1, &n1, flags_for_folder);
+ }
+ else { /* Not UTF-8, get UTF-8 fold */
+ _to_uni_fold_flags(*p1, foldbuf1, &n1, flags_for_folder);
+ }
+ f1 = foldbuf1;
+ }
}
if (n2 == 0) { /* Same for s2 */
if (flags & FOLDEQ_S2_ALREADY_FOLDED) {
f2 = (U8 *) p2;
+ assert(u2);
n2 = UTF8SKIP(f2);
}
else {
- if ((flags & FOLDEQ_LOCALE)
- && (! u2 || ! UTF8_IS_ABOVE_LATIN1(*p2)))
- {
- /* Here, the next char in s2 is < 256. We've already
- * worked on s1, and if it isn't also < 256, can't match */
- if (u1 && UTF8_IS_ABOVE_LATIN1(*p1)) {
- return 0;
- }
- if (! u2 || UTF8_IS_INVARIANT(*p2)) {
- *foldbuf2 = *p2;
- }
- else {
- *foldbuf2 = TWO_BYTE_UTF8_TO_NATIVE(*p2, *(p2 + 1));
- }
-
- /* Use another function to handle locale rules. We've made
- * sure that both characters to compare are single bytes */
- if (! foldEQ_locale((char *) f1, (char *) foldbuf2, 1)) {
- return 0;
- }
- n1 = n2 = 0;
- }
- else if (isASCII(*p2)) {
- if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) {
- return 0;
- }
- n2 = 1;
- *foldbuf2 = toFOLD(*p2);
- }
- else if (u2) {
- to_utf8_fold(p2, foldbuf2, &n2);
- }
- else {
- to_uni_fold(*p2, foldbuf2, &n2);
- }
- f2 = foldbuf2;
+ if (isASCII(*p2) && ! (flags & FOLDEQ_LOCALE)) {
+ if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) {
+ return 0;
+ }
+ n2 = 1;
+ *foldbuf2 = toFOLD(*p2);
+ }
+ else if (u2) {
+ _to_utf8_fold_flags(p2, foldbuf2, &n2, flags_for_folder);
+ }
+ else {
+ _to_uni_fold_flags(*p2, foldbuf2, &n2, flags_for_folder);
+ }
+ f2 = foldbuf2;
}
}
/* Here f1 and f2 point to the beginning of the strings to compare.
* These strings are the folds of the next character from each input
- * string, stored in utf8. */
+ * string, stored in UTF-8. */
/* While there is more to look for in both folds, see if they
* continue to match */
=for apidoc uvuni_to_utf8_flags
Instead you almost certainly want to use L</uvchr_to_utf8> or
-L</uvchr_to_utf8_flags>>.
+L</uvchr_to_utf8_flags>.
This function is a deprecated synonym for L</uvoffuni_to_utf8_flags>,
which itself, while not deprecated, should be used only in isolated
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/