/*
=head1 Unicode Support
-
-This file contains various utility functions for manipulating UTF8-encoded
+These are 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
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
&& ckWARN3_d(WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR))
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);
+ assert(0);
+#endif
return NULL;
}
}
}
/*
-
-Tests if the first C<len> bytes of string C<s> form a valid UTF-8
-character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a
-valid UTF-8 character. The number of bytes in the UTF-8 character
-will be returned if it is valid, otherwise 0.
-
-This is the "slow" version as opposed to the "fast" version which is
-the "unrolled" IS_UTF8_CHAR(). E.g. for t/uni/class.t the speed
-difference is a factor of 2 to 3. For lengths (UTF8SKIP(s)) of four
-or less you should use the IS_UTF8_CHAR(), for lengths of five or more
-you should use the _slow(). In practice this means that the _slow()
-will be used very rarely, since the maximum Unicode code point (as of
-Unicode 4.1) is U+10FFFF, which encodes in UTF-8 to four bytes. Only
-the "Perl extended UTF-8" (e.g, the infamous 'v-strings') will encode into
-five bytes or more.
-
-=cut */
-PERL_STATIC_INLINE STRLEN
-S_is_utf8_char_slow(const U8 *s, const STRLEN len)
-{
- dTHX; /* The function called below requires thread context */
-
- STRLEN actual_len;
-
- PERL_ARGS_ASSERT_IS_UTF8_CHAR_SLOW;
-
- utf8n_to_uvchr(s, len, &actual_len, UTF8_CHECK_ONLY);
-
- return (actual_len == (STRLEN) -1) ? 0 : actual_len;
-}
-
-/*
=for apidoc is_utf8_char_buf
-Returns the number of bytes that comprise the first UTF-8 encoded character in
-buffer C<buf>. C<buf_end> should point to one position beyond the end of the
-buffer. 0 is returned if C<buf> does not point to a complete, valid UTF-8
-encoded character.
-
-Note that an INVARIANT character (i.e. ASCII on non-EBCDIC
-machines) is a valid UTF-8 character.
+This is identical to the macro L</isUTF8_CHAR>.
=cut */
Perl_is_utf8_char_buf(const U8 *buf, const U8* buf_end)
{
- STRLEN len;
-
PERL_ARGS_ASSERT_IS_UTF8_CHAR_BUF;
- if (buf_end <= buf) {
- return 0;
- }
-
- len = buf_end - buf;
- if (len > UTF8SKIP(buf)) {
- len = UTF8SKIP(buf);
- }
-
- if (IS_UTF8_CHAR_FAST(len))
- return IS_UTF8_CHAR(buf, len) ? len : 0;
- return is_utf8_char_slow(buf, len);
-}
-
-/*
-=for apidoc is_utf8_char
-
-Tests if some arbitrary number of bytes begins in a valid UTF-8
-character. Note that an INVARIANT (i.e. ASCII on non-EBCDIC machines)
-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.
-
-This function is deprecated due to the possibility that malformed input could
-cause reading beyond the end of the input buffer. Use L</is_utf8_char_buf>
-instead.
-
-=cut */
-
-STRLEN
-Perl_is_utf8_char(const U8 *s)
-{
- PERL_ARGS_ASSERT_IS_UTF8_CHAR;
-
- /* Assumes we have enough space, which is why this is deprecated */
- return is_utf8_char_buf(s, s + UTF8SKIP(s));
+ return isUTF8_CHAR(buf, buf_end);
}
-
/*
=for apidoc is_utf8_string
PERL_ARGS_ASSERT_IS_UTF8_STRING;
while (x < send) {
- /* Inline the easy bits of is_utf8_char() here for speed... */
- if (UTF8_IS_INVARIANT(*x)) {
- x++;
- }
- else {
- /* ... and call is_utf8_char() only if really needed. */
- const STRLEN c = UTF8SKIP(x);
- const U8* const next_char_ptr = x + c;
-
- if (next_char_ptr > send) {
- return FALSE;
- }
-
- if (IS_UTF8_CHAR_FAST(c)) {
- if (!IS_UTF8_CHAR(x, c))
- return FALSE;
- }
- else if (! is_utf8_char_slow(x, c)) {
- return FALSE;
- }
- x = next_char_ptr;
- }
+ STRLEN len = isUTF8_CHAR(x, send);
+ if (UNLIKELY(! len)) {
+ return FALSE;
+ }
+ x += len;
}
return TRUE;
{
const U8* const send = s + (len ? len : strlen((const char *)s));
const U8* x = s;
- STRLEN c;
STRLEN outlen = 0;
PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
while (x < send) {
- const U8* next_char_ptr;
-
- /* Inline the easy bits of is_utf8_char() here for speed... */
- if (UTF8_IS_INVARIANT(*x))
- next_char_ptr = x + 1;
- else {
- /* ... and call is_utf8_char() only if really needed. */
- c = UTF8SKIP(x);
- next_char_ptr = c + x;
- if (next_char_ptr > send) {
- goto out;
- }
- if (IS_UTF8_CHAR_FAST(c)) {
- if (!IS_UTF8_CHAR(x, c))
- c = 0;
- } else
- c = is_utf8_char_slow(x, c);
- if (!c)
- goto out;
- }
- x = next_char_ptr;
- outlen++;
+ STRLEN len = isUTF8_CHAR(x, send);
+ if (UNLIKELY(! len)) {
+ goto out;
+ }
+ x += len;
+ outlen++;
}
out:
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;
UV uv = *s;
PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
+ PERL_UNUSED_CONTEXT;
if (retlen) {
*retlen = expectlen;
}
/*
-=for apidoc utf8_to_uvchr
-
-Returns the native code point of the first character in the string C<s>
-which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
-length, in bytes, of that character.
-
-Some, but not all, UTF-8 malformations are detected, and in fact, some
-malformed input could cause reading beyond the end of the input buffer, which
-is why this function is deprecated. Use L</utf8_to_uvchr_buf> instead.
-
-If C<s> points to one of the detected malformations, 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 (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 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.
-
-=cut
-*/
-
-UV
-Perl_utf8_to_uvchr(pTHX_ const U8 *s, STRLEN *retlen)
-{
- PERL_ARGS_ASSERT_UTF8_TO_UVCHR;
-
- return utf8_to_uvchr_buf(s, s + UTF8_MAXBYTES, retlen);
-}
-
-/*
=for apidoc utf8_to_uvuni_buf
Only in very rare circumstances should code need to be dealing in Unicode
ckWARN_d(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY));
}
-/* DEPRECATED!
- * Like L</utf8_to_uvuni_buf>(), but should only be called when it is known that
- * there are no malformations in the input UTF-8 string C<s>. Surrogates,
- * non-character code points, and non-Unicode code points are allowed */
-
-UV
-Perl_valid_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
-{
- PERL_ARGS_ASSERT_VALID_UTF8_TO_UVUNI;
-
- return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
-}
-
-/*
-=for apidoc utf8_to_uvuni
-
-Returns the Unicode code point of the first character in the string C<s>
-which is assumed to be in UTF-8 encoding; C<retlen> will be set to the
-length, in bytes, of that character.
-
-Some, but not all, UTF-8 malformations are detected, and in fact, some
-malformed input could cause reading beyond the end of the input buffer, which
-is one reason why this function is deprecated. The other is that only in
-extremely limited circumstances should the Unicode versus native code point be
-of any interest to you. See L</utf8_to_uvuni_buf> for alternatives.
-
-If C<s> points to one of the detected malformations, and UTF8 warnings are
-enabled, zero is returned and C<*retlen> is set (if C<retlen> doesn't point to
-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 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.
-
-=cut
-*/
-
-UV
-Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen)
-{
- PERL_ARGS_ASSERT_UTF8_TO_UVUNI;
-
- return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
-}
-
/*
=for apidoc utf8_length
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)) {
U8 *d;
PERL_ARGS_ASSERT_UTF8_TO_BYTES;
+ PERL_UNUSED_CONTEXT;
/* ensure valid UTF-8 and chars < 256 before updating string */
while (s < send) {
I32 count = 0;
PERL_ARGS_ASSERT_BYTES_FROM_UTF8;
-
PERL_UNUSED_CONTEXT;
if (!*is_utf8)
return (U8 *)start;
/* Internal function so we can deprecate the external one, and call
this one from other deprecated functions in this file */
-PERL_STATIC_INLINE bool
-S_is_utf8_idfirst(pTHX_ const U8 *p)
+bool
+Perl__is_utf8_idstart(pTHX_ const U8 *p)
{
- dVAR;
+ PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
if (*p == '_')
return TRUE;
- /* is_utf8_idstart would be more logical. */
return is_utf8_common(p, &PL_utf8_idstart, "IdStart", NULL);
}
bool
-Perl_is_uni_idfirst(pTHX_ UV c)
-{
- U8 tmpbuf[UTF8_MAXBYTES+1];
- uvchr_to_utf8(tmpbuf, c);
- return S_is_utf8_idfirst(aTHX_ tmpbuf);
-}
-
-bool
Perl__is_uni_perl_idcont(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
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
*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));
* 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>,
* as far as there being enough bytes available in it to accommodate the
* character without reading beyond the end, and pass that number on to the
* validating routine */
- if (! is_utf8_char_buf(p, p + UTF8SKIP(p))) {
+ if (! isUTF8_CHAR(p, p + UTF8SKIP(p))) {
if (ckWARN_d(WARN_UTF8)) {
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED,WARN_UTF8),
"Passing malformed UTF-8 to \"%s\" is deprecated", swashname);
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_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
+Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
{
- dVAR;
+ SV* invlist = NULL;
- PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
+ PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
- return S_is_utf8_idfirst(aTHX_ p);
+ if (! PL_utf8_perl_idstart) {
+ invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
+ }
+ return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart", invlist);
}
bool
-Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */
+Perl__is_utf8_xidstart(pTHX_ const U8 *p)
{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST;
+ PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
if (*p == '_')
return TRUE;
- /* is_utf8_idstart would be more logical. */
return is_utf8_common(p, &PL_utf8_xidstart, "XIdStart", NULL);
}
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);
-}
-
-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)
+Perl__is_utf8_idcont(pTHX_ const U8 *p)
{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
+ 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)
+Perl__is_utf8_xidcont(pTHX_ const U8 *p)
{
- dVAR;
-
- PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
+ 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);
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);
}
STATIC UV
-S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
+S_check_locale_boundary_crossing(pTHX_ const char * const func_name, 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
* the Latin1 range, and the operation is in a non-UTF-8 locale. If the
/* 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"}\".",
+ func_name,
+ 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;
result = CALL_UPPER_CASE(p, ustrp, lenp);
if (flags) {
- result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ result = check_locale_boundary_crossing("uc", p, result, ustrp, lenp);
}
return result;
}
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;
result = CALL_TITLE_CASE(p, ustrp, lenp);
if (flags) {
- result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ result = check_locale_boundary_crossing("ucfirst", p, result, ustrp, lenp);
}
return result;
}
{
UV result;
- dVAR;
-
PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
if (flags && IN_UTF8_CTYPE_LOCALE) {
result = CALL_LOWER_CASE(p, ustrp, lenp);
if (flags) {
- result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ result = check_locale_boundary_crossing("lc", p, result, ustrp, lenp);
}
return result;
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;
&& memEQ((char *) p, LATIN_CAPITAL_LETTER_SHARP_S_UTF8,
sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 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{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))
{
+ /* 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;
}
- return check_locale_boundary_crossing(p, result, ustrp, lenp);
+ return check_locale_boundary_crossing("fc", p, result, ustrp, lenp);
}
else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
return result;
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, "")) {
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
SAVEHINTS();
- save_re_context();
/* We might get here via a subroutine signature which uses a utf8
* parameter name, at which point PL_subname will have been set
* but not yet used. */
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));
- Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
+ NOT_REACHED; /* NOTREACHED */
}
} /* End of calling the module to find the swash */
}
}
- return retval;
+ CORE_SWASH_INIT_RETURN(retval);
+#undef CORE_SWASH_INIT_RETURN
}
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;
STRLEN slen = 0;
STRLEN needents;
const U8 *tmps = NULL;
- U32 bit;
SV *swatch;
const U8 c = *ptr;
switch ((int)((slen << 3) / needents)) {
case 1:
- bit = 1 << (off & 7);
- off >>= 3;
- return (tmps[off] & bit) != 0;
+ return ((UV) tmps[off >> 3] & (1 << (off & 7))) != 0;
case 8:
- return tmps[off];
+ return ((UV) tmps[off]);
case 16:
off <<= 1;
- return (tmps[off] << 8) + tmps[off + 1] ;
+ return
+ ((UV) tmps[off ] << 8) +
+ ((UV) tmps[off + 1]);
case 32:
off <<= 2;
- return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
+ return
+ ((UV) tmps[off ] << 24) +
+ ((UV) tmps[off + 1] << 16) +
+ ((UV) tmps[off + 2] << 8) +
+ ((UV) tmps[off + 3]);
}
Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width, "
"slen=%"UVuf", needents=%"UVuf, (UV)slen, (UV)needents);
/* nl points to the next \n in the scan */
U8* const nl = (U8*)memchr(l, '\n', lend - l);
+ PERL_ARGS_ASSERT_SWASH_SCAN_LIST_LINE;
+
/* Get the first number on the line: the range minimum */
numlen = lend - l;
*min = grok_hex((char *)l, &numlen, &flags, NULL);
+ *max = *min; /* So can never return without setting max */
if (numlen) /* If found a hex number, position past it */
l += numlen;
else if (nl) { /* Else, go handle next line, if any */
}
else { /* Nothing following range min, should be single element with no
mapping expected */
- *max = *min;
if (wants_value) {
*val = 0;
if (typeto) {
lend = l + lcur;
while (l < lend) {
UV min, max, val, upper;
- l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
- cBOOL(octets), typestr);
+ l = swash_scan_list_line(l, lend, &min, &max, &val,
+ cBOOL(octets), typestr);
if (l > lend) {
break;
}
while (l < lend) {
UV min, max, val;
UV inverse;
- l = S_swash_scan_list_line(aTHX_ l, lend, &min, &max, &val,
- cBOOL(octets), typestr);
+ l = swash_scan_list_line(l, lend, &min, &max, &val,
+ cBOOL(octets), typestr);
if (l > lend) {
break;
}
for (i = 0; i <= av_tindex(list); i++) {
SV** entryp = av_fetch(list, i, FALSE);
SV* entry;
+ UV uv;
if (entryp == NULL) {
Perl_croak(aTHX_ "panic: av_fetch() unexpectedly failed");
}
entry = *entryp;
- /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, SvUV(entry)));*/
- if (SvUV(entry) == val) {
+ uv = SvUV(entry);
+ /*DEBUG_U(PerlIO_printf(Perl_debug_log, "list for %"UVXf" contains %"UVXf"\n", val, uv));*/
+ if (uv == val) {
found_key = TRUE;
}
- if (SvUV(entry) == inverse) {
+ if (uv == inverse) {
found_inverse = TRUE;
}
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);
+ elements = grok_atou((const char *)l, &after_atou);
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++;
+ element0 = (UV) grok_atou((const char *)l, &after_atou);
+ 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++;
+ *other_elements_ptr++ = (UV) grok_atou((const char *)l, &after_atou);
+ l = (U8 *) after_atou;
}
}
}
UV start, end;
UV val; /* Not used by this function */
- l = S_swash_scan_list_line(aTHX_ l, lend, &start, &end, &val,
- cBOOL(octets), typestr);
+ l = swash_scan_list_line(l, lend, &start, &end, &val,
+ cBOOL(octets), typestr);
if (l > lend) {
break;
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 */
return 1;
}
-/* XXX The next four functions should likely be moved to mathoms.c once all
+/* XXX The next two functions should likely be moved to mathoms.c once all
* occurrences of them are removed from the core; some cpan-upstream modules
* still use them */
return Perl_uvoffuni_to_utf8_flags(aTHX_ d, uv, 0);
}
+/*
+=for apidoc utf8n_to_uvuni
+
+Instead use L</utf8_to_uvchr_buf>, or rarely, L</utf8n_to_uvchr>.
+
+This function was useful for code that wanted to handle both EBCDIC and
+ASCII platforms with Unicode properties, but starting in Perl v5.20, the
+distinctions between the platforms have mostly been made invisible to most
+code, so this function is quite unlikely to be what you want. If you do need
+this precise functionality, use instead
+C<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>>
+or C<L<NATIVE_TO_UNI(utf8n_to_uvchr(...))|/utf8n_to_uvchr>>.
+
+=cut
+*/
+
UV
Perl_utf8n_to_uvuni(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
}
/*
-=for apidoc utf8n_to_uvuni
-
-Instead use L</utf8_to_uvchr_buf>, or rarely, L</utf8n_to_uvchr>.
-
-This function was useful for code that wanted to handle both EBCDIC and
-ASCII platforms with Unicode properties, but starting in Perl v5.20, the
-distinctions between the platforms have mostly been made invisible to most
-code, so this function is quite unlikely to be what you want. If you do need
-this precise functionality, use instead
-C<L<NATIVE_TO_UNI(utf8_to_uvchr_buf(...))|/utf8_to_uvchr_buf>>
-or C<L<NATIVE_TO_UNI(utf8n_to_uvchr(...))|/utf8n_to_uvchr>>.
-
-=cut
-*/
-
-/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
https://perl5.git.perl.org / perl5.git / blobdiff