* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*
+ * This file contains tables and code adapted from
+ * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
+ * copyright notice:
+
+Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+ *
* This file is a home for static inline functions that cannot go in other
* header files, because they depend on proto.h (included after most other
* headers) or struct definitions.
/* ------------------------------- av.h ------------------------------- */
-PERL_STATIC_INLINE SSize_t
-S_av_top_index(pTHX_ AV *av)
+/*
+=for apidoc_section $AV
+=for apidoc av_count
+Returns the number of elements in the array C<av>. This is the true length of
+the array, including any undefined elements. It is always the same as
+S<C<av_top_index(av) + 1>>.
+
+=cut
+*/
+PERL_STATIC_INLINE Size_t
+Perl_av_count(pTHX_ AV *av)
{
- PERL_ARGS_ASSERT_AV_TOP_INDEX;
+ PERL_ARGS_ASSERT_AV_COUNT;
assert(SvTYPE(av) == SVt_PVAV);
- return AvFILL(av);
+ return AvFILL(av) + 1;
}
/* ------------------------------- cv.h ------------------------------- */
+/*
+=for apidoc_section $CV
+=for apidoc CvGV
+Returns the GV associated with the CV C<sv>, reifying it if necessary.
+
+=cut
+*/
PERL_STATIC_INLINE GV *
-S_CvGV(pTHX_ CV *sv)
+Perl_CvGV(pTHX_ CV *sv)
{
+ PERL_ARGS_ASSERT_CVGV;
+
return CvNAMED(sv)
? Perl_cvgv_from_hek(aTHX_ sv)
: ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
}
PERL_STATIC_INLINE I32 *
-S_CvDEPTHp(const CV * const sv)
+Perl_CvDEPTH(const CV * const sv)
{
+ PERL_ARGS_ASSERT_CVDEPTH;
assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
+
return &((XPVCV*)SvANY(sv))->xcv_depth;
}
#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
PERL_STATIC_INLINE bool
-PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
+S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
{
+ PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
+
/* is seq within the range _LOW to _HIGH ?
* This is complicated by the fact that PL_cop_seqmax
* may have wrapped around at some point */
/* ------------------------------- pp.h ------------------------------- */
PERL_STATIC_INLINE I32
-S_TOPMARK(pTHX)
+Perl_TOPMARK(pTHX)
{
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
"MARK top %p %" IVdf "\n",
}
PERL_STATIC_INLINE I32
-S_POPMARK(pTHX)
+Perl_POPMARK(pTHX)
{
DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
"MARK pop %p %" IVdf "\n",
/* ----------------------------- regexp.h ----------------------------- */
PERL_STATIC_INLINE struct regexp *
-S_ReANY(const REGEXP * const re)
+Perl_ReANY(const REGEXP * const re)
{
XPV* const p = (XPV*)SvANY(re);
+
+ PERL_ARGS_ASSERT_REANY;
assert(isREGEXP(re));
+
return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
: (struct regexp *)p;
}
/* ------------------------------- sv.h ------------------------------- */
+PERL_STATIC_INLINE bool
+Perl_SvTRUE(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SVTRUE;
+
+ if (UNLIKELY(sv == NULL))
+ return FALSE;
+ SvGETMAGIC(sv);
+ return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_nomg(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SVTRUE_NOMG;
+
+ if (UNLIKELY(sv == NULL))
+ return FALSE;
+ return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_NN(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SVTRUE_NN;
+
+ SvGETMAGIC(sv);
+ return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
+{
+ PERL_ARGS_ASSERT_SVTRUE_COMMON;
+
+ if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
+ return SvIMMORTAL_TRUE(sv);
+
+ if (! SvOK(sv))
+ return FALSE;
+
+ if (SvPOK(sv))
+ return SvPVXtrue(sv);
+
+ if (SvIOK(sv))
+ return SvIVX(sv) != 0; /* casts to bool */
+
+ if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
+ return TRUE;
+
+ if (sv_2bool_is_fallback)
+ return sv_2bool_nomg(sv);
+
+ return isGV_with_GP(sv);
+}
+
+
PERL_STATIC_INLINE SV *
-S_SvREFCNT_inc(SV *sv)
+Perl_SvREFCNT_inc(SV *sv)
{
if (LIKELY(sv != NULL))
SvREFCNT(sv)++;
return sv;
}
PERL_STATIC_INLINE SV *
-S_SvREFCNT_inc_NN(SV *sv)
+Perl_SvREFCNT_inc_NN(SV *sv)
{
+ PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
+
SvREFCNT(sv)++;
return sv;
}
PERL_STATIC_INLINE void
-S_SvREFCNT_inc_void(SV *sv)
+Perl_SvREFCNT_inc_void(SV *sv)
{
if (LIKELY(sv != NULL))
SvREFCNT(sv)++;
}
PERL_STATIC_INLINE void
-S_SvREFCNT_dec(pTHX_ SV *sv)
+Perl_SvREFCNT_dec(pTHX_ SV *sv)
{
if (LIKELY(sv != NULL)) {
U32 rc = SvREFCNT(sv);
}
PERL_STATIC_INLINE void
-S_SvREFCNT_dec_NN(pTHX_ SV *sv)
+Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
{
U32 rc = SvREFCNT(sv);
+
+ PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
+
if (LIKELY(rc > 1))
SvREFCNT(sv) = rc - 1;
else
}
PERL_STATIC_INLINE void
-SvAMAGIC_on(SV *sv)
+Perl_SvAMAGIC_on(SV *sv)
{
+ PERL_ARGS_ASSERT_SVAMAGIC_ON;
assert(SvROK(sv));
+
if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
}
PERL_STATIC_INLINE void
-SvAMAGIC_off(SV *sv)
+Perl_SvAMAGIC_off(SV *sv)
{
+ PERL_ARGS_ASSERT_SVAMAGIC_OFF;
+
if (SvROK(sv) && SvOBJECT(SvRV(sv)))
HvAMAGIC_off(SvSTASH(SvRV(sv)));
}
PERL_STATIC_INLINE U32
-S_SvPADSTALE_on(SV *sv)
+Perl_SvPADSTALE_on(SV *sv)
{
assert(!(SvFLAGS(sv) & SVs_PADTMP));
return SvFLAGS(sv) |= SVs_PADSTALE;
}
PERL_STATIC_INLINE U32
-S_SvPADSTALE_off(SV *sv)
+Perl_SvPADSTALE_off(SV *sv)
{
assert(!(SvFLAGS(sv) & SVs_PADTMP));
return SvFLAGS(sv) &= ~SVs_PADSTALE;
}
#endif
-/* ------------------------------- handy.h ------------------------------- */
-
-/* saves machine code for a common noreturn idiom typically used in Newx*() */
-GCC_DIAG_IGNORE_DECL(-Wunused-function);
-static void
-S_croak_memory_wrap(void)
-{
- Perl_croak_nocontext("%s",PL_memory_wrap);
-}
-GCC_DIAG_RESTORE_DECL;
-
/* ------------------------------- utf8.h ------------------------------- */
/*
-=head1 Unicode Support
+=for apidoc_section $unicode
*/
PERL_STATIC_INLINE void
-S_append_utf8_from_native_byte(const U8 byte, U8** dest)
+Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
{
/* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
* encoded string at '*dest', updating '*dest' to include it */
/*
=for apidoc valid_utf8_to_uvchr
-Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
-the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
-it passes C<L</isUTF8_CHAR>>. Surrogates, non-character code points, and
-non-Unicode code points are allowed.
+Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
+known that the next character in the input UTF-8 string C<s> is well-formed
+(I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code
+points, and non-Unicode code points are allowed.
=cut
*/
PERL_STATIC_INLINE bool
-S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
+Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
{
const U8* send;
const U8* x = s;
# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
|| BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
- *ep = x + _variant_byte_number(* (PERL_UINTMAX_T *) x);
+ *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
assert(*ep >= s && *ep < send);
return FALSE;
#ifndef EBCDIC
PERL_STATIC_INLINE unsigned int
-S__variant_byte_number(PERL_UINTMAX_T word)
+Perl_variant_byte_number(PERL_UINTMAX_T word)
{
/* This returns the position in a word (0..7) of the first variant byte in
/* Get just the msb bits of each byte */
word &= PERL_VARIANTS_WORD_MASK;
-# ifdef USING_MSVC6 /* VC6 has some issues with the normal code, and the
- easiest thing is to hide that from the callers */
- {
- unsigned int i;
- const U8 * s = (U8 *) &word;
- dTHX;
-
- for (i = 0; i < sizeof(word); i++ ) {
- if (s[i]) {
- return i;
- }
- }
-
- Perl_croak(aTHX_ "panic: %s: %d: unexpected zero word\n",
- __FILE__, __LINE__);
- }
-
-# elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
/* Bytes are stored like
* Byte8 ... Byte2 Byte1
* Isolate the lsb;
* https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
*
- * The word will look this this, with a rightmost set bit in position 's':
+ * The word will look like this, with a rightmost set bit in position 's':
* ('x's are don't cares)
* s
* x..x100..0
* x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
* the 1 just to their left into a 0; the remainder is
* untouched
- * 0..0011..1 The xor with x..xx10..0 clears that remainder, sets
- * bottom to all 1
+ * 0..0011..1 The xor with the original, x..xx10..0, clears that
+ * remainder, sets the bottom to all 1
* 0..0100..0 Add 1 to clear the word except for the bit in 's'
*
* Another method is to do 'word &= -word'; but it generates a compiler
*/
PERL_STATIC_INLINE bool
-S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
+Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
{
const U8 * first_variant;
*/
PERL_STATIC_INLINE bool
-S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
+Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
{
const U8 * first_variant;
/*
+=for apidoc isUTF8_CHAR
+
+Evaluates to non-zero if the first few bytes of the string starting at C<s> and
+looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
+that represents some code point; otherwise it evaluates to 0. If non-zero, the
+value gives how many bytes starting at C<s> comprise the code point's
+representation. Any bytes remaining before C<e>, but beyond the ones needed to
+form the first code point in C<s>, are not examined.
+
+The code point can be any that will fit in an IV on this machine, using Perl's
+extension to official UTF-8 to represent those higher than the Unicode maximum
+of 0x10FFFF. That means that this macro is used to efficiently decide if the
+next few bytes in C<s> is legal UTF-8 for a single character.
+
+Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
+defined by Unicode to be fully interchangeable across applications;
+C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
+#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
+code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
+C<L</is_utf8_string_loclen>> to check entire strings.
+
+Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
+machines) is a valid UTF-8 character.
+
+=cut
+
+This uses an adaptation of the table and algorithm given in
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+documentation of the original version. A copyright notice for the original
+version is given at the beginning of this file. The Perl adapation is
+documented at the definition of PL_extended_utf8_dfa_tab[].
+
+*/
+
+PERL_STATIC_INLINE Size_t
+Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
+{
+ const U8 * s = s0;
+ UV state = 0;
+
+ PERL_ARGS_ASSERT_ISUTF8_CHAR;
+
+ /* This dfa is fast. If it accepts the input, it was for a well-formed,
+ * code point, which can be returned immediately. Otherwise, it is either
+ * malformed, or for the start byte FF which the dfa doesn't handle (except
+ * on 32-bit ASCII platforms where it trivially is an error). Call a
+ * helper function for the other platforms. */
+
+ while (s < e && LIKELY(state != 1)) {
+ state = PL_extended_utf8_dfa_tab[256
+ + state
+ + PL_extended_utf8_dfa_tab[*s]];
+ if (state != 0) {
+ s++;
+ continue;
+ }
+
+ return s - s0 + 1;
+ }
+
+#if defined(UV_IS_QUAD) || defined(EBCDIC)
+
+ if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
+ return is_utf8_char_helper(s0, e, 0);
+ }
+
+#endif
+
+ return 0;
+}
+
+/*
+
+=for apidoc isSTRICT_UTF8_CHAR
+
+Evaluates to non-zero if the first few bytes of the string starting at C<s> and
+looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
+Unicode code point completely acceptable for open interchange between all
+applications; otherwise it evaluates to 0. If non-zero, the value gives how
+many bytes starting at C<s> comprise the code point's representation. Any
+bytes remaining before C<e>, but beyond the ones needed to form the first code
+point in C<s>, are not examined.
+
+The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
+be a surrogate nor a non-character code point. Thus this excludes any code
+point from Perl's extended UTF-8.
+
+This is used to efficiently decide if the next few bytes in C<s> is
+legal Unicode-acceptable UTF-8 for a single character.
+
+Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
+#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
+code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
+and C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
+C<L</is_strict_utf8_string_loclen>> to check entire strings.
+
+=cut
+
+This uses an adaptation of the tables and algorithm given in
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+documentation of the original version. A copyright notice for the original
+version is given at the beginning of this file. The Perl adapation is
+documented at the definition of strict_extended_utf8_dfa_tab[].
+
+*/
+
+PERL_STATIC_INLINE Size_t
+Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
+{
+ const U8 * s = s0;
+ UV state = 0;
+
+ PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
+
+ while (s < e && LIKELY(state != 1)) {
+ state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
+
+ if (state != 0) {
+ s++;
+ continue;
+ }
+
+ return s - s0 + 1;
+ }
+
+#ifndef EBCDIC
+
+ /* The dfa above drops out for certain Hanguls; handle them specially */
+ if (is_HANGUL_ED_utf8_safe(s0, e)) {
+ return 3;
+ }
+
+#endif
+
+ return 0;
+}
+
+/*
+
+=for apidoc isC9_STRICT_UTF8_CHAR
+
+Evaluates to non-zero if the first few bytes of the string starting at C<s> and
+looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
+Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
+the value gives how many bytes starting at C<s> comprise the code point's
+representation. Any bytes remaining before C<e>, but beyond the ones needed to
+form the first code point in C<s>, are not examined.
+
+The largest acceptable code point is the Unicode maximum 0x10FFFF. This
+differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
+code points. This corresponds to
+L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
+which said that non-character code points are merely discouraged rather than
+completely forbidden in open interchange. See
+L<perlunicode/Noncharacter code points>.
+
+Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
+C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
+C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
+
+=cut
+
+This uses an adaptation of the tables and algorithm given in
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+documentation of the original version. A copyright notice for the original
+version is given at the beginning of this file. The Perl adapation is
+documented at the definition of PL_c9_utf8_dfa_tab[].
+
+*/
+
+PERL_STATIC_INLINE Size_t
+Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
+{
+ const U8 * s = s0;
+ UV state = 0;
+
+ PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
+
+ while (s < e && LIKELY(state != 1)) {
+ state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
+
+ if (state != 0) {
+ s++;
+ continue;
+ }
+
+ return s - s0 + 1;
+ }
+
+ return 0;
+}
+
+/*
+
=for apidoc is_strict_utf8_string_loc
Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
*/
PERL_STATIC_INLINE bool
-S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
+Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
{
const U8 * first_variant;
*/
PERL_STATIC_INLINE bool
-S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
+Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
{
const U8 * first_variant;
*/
PERL_STATIC_INLINE bool
-S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
+Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
{
const U8 * first_variant;
assert(off <= 0);
while (off++ && s > start) {
- s--;
- while (UTF8_IS_CONTINUATION(*s) && s > start)
+ do {
s--;
+ } while (UTF8_IS_CONTINUATION(*s) && s > start);
}
-
+
GCC_DIAG_IGNORE(-Wcast-qual)
return (U8 *)s;
GCC_DIAG_RESTORE
*/
PERL_STATIC_INLINE bool
-S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
+Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
{
PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
return FALSE;
}
- return cBOOL(_is_utf8_char_helper(s, e, flags));
+ return cBOOL(is_utf8_char_helper(s, e, flags));
}
/*
*/
PERL_STATIC_INLINE bool
-S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
+Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
STRLEN len,
const U8 **ep,
STRLEN *el,
|| is_utf8_valid_partial_char_flags(*ep, s + len, flags);
}
+PERL_STATIC_INLINE UV
+Perl_utf8n_to_uvchr_msgs(const U8 *s,
+ STRLEN curlen,
+ STRLEN *retlen,
+ const U32 flags,
+ U32 * errors,
+ AV ** msgs)
+{
+ /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
+ * simple cases, and, if necessary calls a helper function to deal with the
+ * more complex ones. Almost all well-formed non-problematic code points
+ * are considered simple, so that it's unlikely that the helper function
+ * will need to be called.
+ *
+ * This is an adaptation of the tables and algorithm given in
+ * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
+ * comprehensive documentation of the original version. A copyright notice
+ * for the original version is given at the beginning of this file. The
+ * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
+ */
+
+ const U8 * const s0 = s;
+ const U8 * send = s0 + curlen;
+ UV uv = 0; /* The 0 silences some stupid compilers */
+ UV state = 0;
+
+ PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
+
+ /* This dfa is fast. If it accepts the input, it was for a well-formed,
+ * non-problematic code point, which can be returned immediately.
+ * Otherwise we call a helper function to figure out the more complicated
+ * cases. */
+
+ while (s < send && LIKELY(state != 1)) {
+ UV type = PL_strict_utf8_dfa_tab[*s];
+
+ uv = (state == 0)
+ ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
+ : UTF8_ACCUMULATE(uv, *s);
+ state = PL_strict_utf8_dfa_tab[256 + state + type];
+
+ if (state != 0) {
+ s++;
+ continue;
+ }
+
+ if (retlen) {
+ *retlen = s - s0 + 1;
+ }
+ if (errors) {
+ *errors = 0;
+ }
+ if (msgs) {
+ *msgs = NULL;
+ }
+
+ return UNI_TO_NATIVE(uv);
+ }
+
+ /* Here is potentially problematic. Use the full mechanism */
+ return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
+}
+
+PERL_STATIC_INLINE UV
+Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
+{
+ PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
+
+ assert(s < send);
+
+ if (! ckWARN_d(WARN_UTF8)) {
+
+ /* EMPTY is not really allowed, and asserts on debugging builds. But
+ * on non-debugging we have to deal with it, and this causes it to
+ * return the REPLACEMENT CHARACTER, as the documentation indicates */
+ return utf8n_to_uvchr(s, send - s, retlen,
+ (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
+ }
+ else {
+ UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
+ if (retlen && ret == 0 && *s != '\0') {
+ *retlen = (STRLEN) -1;
+ }
+
+ return ret;
+ }
+}
+
/* ------------------------------- perl.h ----------------------------- */
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $utility
-=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
+=for apidoc is_safe_syscall
-Test that the given C<pv> doesn't contain any internal C<NUL> characters.
-If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
+Test that the given C<pv> (with length C<len>) doesn't contain any internal
+C<NUL> characters.
+If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
+category, and return FALSE.
Return TRUE if the name is safe.
+C<what> and C<op_name> are used in any warning.
+
Used by the C<IS_SAFE_SYSCALL()> macro.
=cut
*/
PERL_STATIC_INLINE bool
-S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
+Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
+{
/* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
* perl itself uses xce*() functions which accept 8-bit strings.
*/
#ifdef PERL_CORE
PERL_STATIC_INLINE bool
-S_should_warn_nl(const char *pv) {
+S_should_warn_nl(const char *pv)
+{
STRLEN len;
PERL_ARGS_ASSERT_SHOULD_WARN_NL;
#endif
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
+
+PERL_STATIC_INLINE bool
+S_lossless_NV_to_IV(const NV nv, IV *ivp)
+{
+ /* This function determines if the input NV 'nv' may be converted without
+ * loss of data to an IV. If not, it returns FALSE taking no other action.
+ * But if it is possible, it does the conversion, returning TRUE, and
+ * storing the converted result in '*ivp' */
+
+ PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
+
+# if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ /* Normally any comparison with a NaN returns false; if we can't rely
+ * on that behaviour, check explicitly */
+ if (UNLIKELY(Perl_isnan(nv))) {
+ return FALSE;
+ }
+# endif
+
+ /* Written this way so that with an always-false NaN comparison we
+ * return false */
+ if (!(LIKELY(nv >= (NV) IV_MIN) && LIKELY(nv < IV_MAX_P1))) {
+ return FALSE;
+ }
+
+ if ((IV) nv != nv) {
+ return FALSE;
+ }
+
+ *ivp = (IV) nv;
+ return TRUE;
+}
+
+#endif
+
/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
+
#define MAX_CHARSET_NAME_LENGTH 2
PERL_STATIC_INLINE const char *
-get_regex_charset_name(const U32 flags, STRLEN* const lenp)
+S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
{
+ PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
+
/* Returns a string that corresponds to the name of the regex character set
* given by 'flags', and *lenp is set the length of that string, which
* cannot exceed MAX_CHARSET_NAME_LENGTH characters */
return "?"; /* Unknown */
}
+#endif
+
/*
Return false if any get magic is on the SV other than taint magic.
*/
PERL_STATIC_INLINE bool
-S_sv_only_taint_gmagic(SV *sv) {
+Perl_sv_only_taint_gmagic(SV *sv)
+{
MAGIC *mg = SvMAGIC(sv);
PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
/* ------------------ cop.h ------------------------------------------- */
+/* implement GIMME_V() macro */
+
+PERL_STATIC_INLINE U8
+Perl_gimme_V(pTHX)
+{
+ I32 cxix;
+ U8 gimme = (PL_op->op_flags & OPf_WANT);
+
+ if (gimme)
+ return gimme;
+ cxix = PL_curstackinfo->si_cxsubix;
+ if (cxix < 0)
+ return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
+ assert(cxstack[cxix].blk_gimme & G_WANT);
+ return (cxstack[cxix].blk_gimme & G_WANT);
+}
+
/* Enter a block. Push a new base context and return its address. */
PERL_STATIC_INLINE PERL_CONTEXT *
-S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
+Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
{
PERL_CONTEXT * cx;
/* Exit a block (RETURN and LAST). */
PERL_STATIC_INLINE void
-S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
{
PERL_ARGS_ASSERT_CX_POPBLOCK;
* *after* cx_pushblock() was called. */
PERL_STATIC_INLINE void
-S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
{
PERL_ARGS_ASSERT_CX_TOPBLOCK;
PERL_STATIC_INLINE void
-S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
+Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
{
U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
PERL_ARGS_ASSERT_CX_PUSHSUB;
PERL_DTRACE_PROBE_ENTRY(cv);
+ cx->blk_sub.old_cxsubix = PL_curstackinfo->si_cxsubix;
+ PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
cx->blk_sub.prevcomppad = PL_comppad;
/* subsets of cx_popsub() */
PERL_STATIC_INLINE void
-S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
{
CV *cv;
CvDEPTH(cv) = cx->blk_sub.olddepth;
cx->blk_sub.cv = NULL;
SvREFCNT_dec(cv);
+ PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
}
/* handle the @_ part of leaving a sub */
PERL_STATIC_INLINE void
-S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
{
AV *av;
PERL_STATIC_INLINE void
-S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
{
PERL_ARGS_ASSERT_CX_POPSUB;
assert(CxTYPE(cx) == CXt_SUB);
PERL_STATIC_INLINE void
-S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
+Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
{
PERL_ARGS_ASSERT_CX_PUSHFORMAT;
+ cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
+ PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
cx->blk_format.cv = cv;
cx->blk_format.retop = retop;
cx->blk_format.gv = gv;
PERL_STATIC_INLINE void
-S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
{
CV *cv;
GV *dfout;
cx->blk_format.cv = NULL;
--CvDEPTH(cv);
SvREFCNT_dec_NN(cv);
+ PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
}
PERL_STATIC_INLINE void
-S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
+Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
{
PERL_ARGS_ASSERT_CX_PUSHEVAL;
+ cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
+ PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
cx->blk_eval.retop = retop;
cx->blk_eval.old_namesv = namesv;
cx->blk_eval.old_eval_root = PL_eval_root;
PERL_STATIC_INLINE void
-S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
{
SV *sv;
cx->blk_eval.old_namesv = NULL;
SvREFCNT_dec_NN(sv);
}
+ PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
}
*/
PERL_STATIC_INLINE void
-S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
{
PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
cx->blk_loop.my_op = cLOOP;
*/
PERL_STATIC_INLINE void
-S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
+Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
{
PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
/* pop all loop types, including plain */
PERL_STATIC_INLINE void
-S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
{
PERL_ARGS_ASSERT_CX_POPLOOP;
PERL_STATIC_INLINE void
-S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
{
PERL_ARGS_ASSERT_CX_PUSHWHEN;
PERL_STATIC_INLINE void
-S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
{
PERL_ARGS_ASSERT_CX_POPWHEN;
assert(CxTYPE(cx) == CXt_WHEN);
PERL_STATIC_INLINE void
-S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
+Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
{
PERL_ARGS_ASSERT_CX_PUSHGIVEN;
PERL_STATIC_INLINE void
-S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
{
SV *sv;
/* ------------------ util.h ------------------------------------------- */
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $string
=for apidoc foldEQ
PERL_STATIC_INLINE I32
Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
{
- /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
- * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
- * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
- * does it check that the strings each have at least 'len' characters */
+ /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
+ * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
+ * does not check for this. Nor does it check that the strings each have
+ * at least 'len' characters. */
const U8 *a = (const U8 *)s1;
const U8 *b = (const U8 *)s2;
}
/*
+=for apidoc_section $locale
=for apidoc foldEQ_locale
Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
PERL_STATIC_INLINE I32
Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
{
- dVAR;
const U8 *a = (const U8 *)s1;
const U8 *b = (const U8 *)s2;
return 1;
}
+/*
+=for apidoc_section $string
+=for apidoc my_strnlen
+
+The C library C<strnlen> if available, or a Perl implementation of it.
+
+C<my_strnlen()> computes the length of the string, up to C<maxlen>
+characters. It will never attempt to address more than C<maxlen>
+characters, making it suitable for use with strings that are not
+guaranteed to be NUL-terminated.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strnlen.3,
+implementation stolen from PostgreSQL.
+*/
+#ifndef HAS_STRNLEN
+
+PERL_STATIC_INLINE Size_t
+Perl_my_strnlen(const char *str, Size_t maxlen)
+{
+ const char *end = (char *) memchr(str, '\0', maxlen);
+
+ PERL_ARGS_ASSERT_MY_STRNLEN;
+
+ if (end == NULL) return maxlen;
+ return end - str;
+}
+
+#endif
+
#if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
PERL_STATIC_INLINE void *
#endif
+PERL_STATIC_INLINE char *
+Perl_mortal_getenv(const char * str)
+{
+ /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
+ *
+ * It's (mostly) thread-safe because it uses a mutex to prevent
+ * simultaneous access from other threads that use the same mutex, and
+ * makes a copy of the result before releasing that mutex. All of the Perl
+ * core uses that mutex, but, like all mutexes, everything has to cooperate
+ * for it to completely work. It is possible for code from, say XS, to not
+ * use this mutex, defeating the safety.
+ *
+ * On some platforms, getenv() is not sequential-call-safe, because
+ * subsequent calls destroy the static storage inside the C library
+ * returned by an earlier call. The result must be copied or completely
+ * acted upon before a subsequent getenv call. Those calls could come from
+ * another thread. Again, making a copy while controlling the mutex
+ * prevents these problems..
+ *
+ * To prevent leaks, the copy is made by creating a new SV containing it,
+ * mortalizing the SV, and returning the SV's string (the copy). Thus this
+ * is a drop-in replacement for getenv().
+ *
+ * A complication is that this can be called during phases where the
+ * mortalization process isn't available. These are in interpreter
+ * destruction or early in construction. khw believes that at these times
+ * there shouldn't be anything else going on, so plain getenv is safe AS
+ * LONG AS the caller acts on the return before calling it again. */
+
+ char * ret;
+ dTHX;
+
+ PERL_ARGS_ASSERT_MORTAL_GETENV;
+
+ /* Can't mortalize without stacks. khw believes that no other threads
+ * should be running, so no need to lock things, and this may be during a
+ * phase when locking isn't even available */
+ if (UNLIKELY(PL_scopestack_ix == 0)) {
+ return getenv(str);
+ }
+
+ GETENV_LOCK;
+
+ ret = getenv(str);
+
+ if (ret != NULL) {
+ ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
+ }
+
+ GETENV_UNLOCK;
+
+ return ret;
+}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff