inline.h

   1 /*    inline.h
   2  *
   3  *    Copyright (C) 2012 by Larry Wall and others
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  *    This file contains tables and code adapted from
   9  *    https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
  10  *    copyright notice:
  11
  12 Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
  13
  14 Permission is hereby granted, free of charge, to any person obtaining a copy of
  15 this software and associated documentation files (the "Software"), to deal in
  16 the Software without restriction, including without limitation the rights to
  17 use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
  18 of the Software, and to permit persons to whom the Software is furnished to do
  19 so, subject to the following conditions:
  20
  21 The above copyright notice and this permission notice shall be included in all
  22 copies or substantial portions of the Software.
  23
  24 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  25 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  26 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  27 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  28 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  29 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  30 SOFTWARE.
  31
  32  *
  33  * This file is a home for static inline functions that cannot go in other
  34  * header files, because they depend on proto.h (included after most other
  35  * headers) or struct definitions.
  36  *
  37  * Each section names the header file that the functions "belong" to.
  38  */
  39
  40 /* ------------------------------- av.h ------------------------------- */
  41
  42 PERL_STATIC_INLINE SSize_t
  43 Perl_av_top_index(pTHX_ AV *av)
  44 {
  45     PERL_ARGS_ASSERT_AV_TOP_INDEX;
  46     assert(SvTYPE(av) == SVt_PVAV);
  47
  48     return AvFILL(av);
  49 }
  50
  51 /* ------------------------------- cv.h ------------------------------- */
  52
  53 PERL_STATIC_INLINE GV *
  54 Perl_CvGV(pTHX_ CV *sv)
  55 {
  56     PERL_ARGS_ASSERT_CVGV;
  57
  58     return CvNAMED(sv)
  59         ? Perl_cvgv_from_hek(aTHX_ sv)
  60         : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
  61 }
  62
  63 PERL_STATIC_INLINE I32 *
  64 Perl_CvDEPTH(const CV * const sv)
  65 {
  66     PERL_ARGS_ASSERT_CVDEPTH;
  67     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
  68
  69     return &((XPVCV*)SvANY(sv))->xcv_depth;
  70 }
  71
  72 /*
  73  CvPROTO returns the prototype as stored, which is not necessarily what
  74  the interpreter should be using. Specifically, the interpreter assumes
  75  that spaces have been stripped, which has been the case if the prototype
  76  was added by toke.c, but is generally not the case if it was added elsewhere.
  77  Since we can't enforce the spacelessness at assignment time, this routine
  78  provides a temporary copy at parse time with spaces removed.
  79  I<orig> is the start of the original buffer, I<len> is the length of the
  80  prototype and will be updated when this returns.
  81  */
  82
  83 #ifdef PERL_CORE
  84 PERL_STATIC_INLINE char *
  85 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
  86 {
  87     SV * tmpsv;
  88     char * tmps;
  89     tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
  90     tmps = SvPVX(tmpsv);
  91     while ((*len)--) {
  92         if (!isSPACE(*orig))
  93             *tmps++ = *orig;
  94         orig++;
  95     }
  96     *tmps = '\0';
  97     *len = tmps - SvPVX(tmpsv);
  98                 return SvPVX(tmpsv);
  99 }
 100 #endif
 101
 102 /* ------------------------------- mg.h ------------------------------- */
 103
 104 #if defined(PERL_CORE) || defined(PERL_EXT)
 105 /* assumes get-magic and stringification have already occurred */
 106 PERL_STATIC_INLINE STRLEN
 107 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
 108 {
 109     assert(mg->mg_type == PERL_MAGIC_regex_global);
 110     assert(mg->mg_len != -1);
 111     if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
 112         return (STRLEN)mg->mg_len;
 113     else {
 114         const STRLEN pos = (STRLEN)mg->mg_len;
 115         /* Without this check, we may read past the end of the buffer: */
 116         if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
 117         return sv_or_pv_pos_u2b(sv, s, pos, NULL);
 118     }
 119 }
 120 #endif
 121
 122 /* ------------------------------- pad.h ------------------------------ */
 123
 124 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 125 PERL_STATIC_INLINE bool
 126 S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
 127 {
 128     PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
 129
 130     /* is seq within the range _LOW to _HIGH ?
 131      * This is complicated by the fact that PL_cop_seqmax
 132      * may have wrapped around at some point */
 133     if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
 134         return FALSE; /* not yet introduced */
 135
 136     if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
 137     /* in compiling scope */
 138         if (
 139             (seq >  COP_SEQ_RANGE_LOW(pn))
 140             ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
 141             : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
 142         )
 143             return TRUE;
 144     }
 145     else if (
 146         (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
 147         ?
 148             (  seq >  COP_SEQ_RANGE_LOW(pn)
 149             || seq <= COP_SEQ_RANGE_HIGH(pn))
 150
 151         :    (  seq >  COP_SEQ_RANGE_LOW(pn)
 152              && seq <= COP_SEQ_RANGE_HIGH(pn))
 153     )
 154         return TRUE;
 155     return FALSE;
 156 }
 157 #endif
 158
 159 /* ------------------------------- pp.h ------------------------------- */
 160
 161 PERL_STATIC_INLINE I32
 162 Perl_TOPMARK(pTHX)
 163 {
 164     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
 165                                  "MARK top  %p %" IVdf "\n",
 166                                   PL_markstack_ptr,
 167                                   (IV)*PL_markstack_ptr)));
 168     return *PL_markstack_ptr;
 169 }
 170
 171 PERL_STATIC_INLINE I32
 172 Perl_POPMARK(pTHX)
 173 {
 174     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
 175                                  "MARK pop  %p %" IVdf "\n",
 176                                   (PL_markstack_ptr-1),
 177                                   (IV)*(PL_markstack_ptr-1))));
 178     assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
 179     return *PL_markstack_ptr--;
 180 }
 181
 182 /* ----------------------------- regexp.h ----------------------------- */
 183
 184 PERL_STATIC_INLINE struct regexp *
 185 Perl_ReANY(const REGEXP * const re)
 186 {
 187     XPV* const p = (XPV*)SvANY(re);
 188
 189     PERL_ARGS_ASSERT_REANY;
 190     assert(isREGEXP(re));
 191
 192     return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
 193                                    : (struct regexp *)p;
 194 }
 195
 196 /* ------------------------------- sv.h ------------------------------- */
 197
 198 PERL_STATIC_INLINE SV *
 199 Perl_SvREFCNT_inc(SV *sv)
 200 {
 201     if (LIKELY(sv != NULL))
 202         SvREFCNT(sv)++;
 203     return sv;
 204 }
 205 PERL_STATIC_INLINE SV *
 206 Perl_SvREFCNT_inc_NN(SV *sv)
 207 {
 208     PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
 209
 210     SvREFCNT(sv)++;
 211     return sv;
 212 }
 213 PERL_STATIC_INLINE void
 214 Perl_SvREFCNT_inc_void(SV *sv)
 215 {
 216     if (LIKELY(sv != NULL))
 217         SvREFCNT(sv)++;
 218 }
 219 PERL_STATIC_INLINE void
 220 Perl_SvREFCNT_dec(pTHX_ SV *sv)
 221 {
 222     if (LIKELY(sv != NULL)) {
 223         U32 rc = SvREFCNT(sv);
 224         if (LIKELY(rc > 1))
 225             SvREFCNT(sv) = rc - 1;
 226         else
 227             Perl_sv_free2(aTHX_ sv, rc);
 228     }
 229 }
 230
 231 PERL_STATIC_INLINE void
 232 Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
 233 {
 234     U32 rc = SvREFCNT(sv);
 235
 236     PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
 237
 238     if (LIKELY(rc > 1))
 239         SvREFCNT(sv) = rc - 1;
 240     else
 241         Perl_sv_free2(aTHX_ sv, rc);
 242 }
 243
 244 PERL_STATIC_INLINE void
 245 Perl_SvAMAGIC_on(SV *sv)
 246 {
 247     PERL_ARGS_ASSERT_SVAMAGIC_ON;
 248     assert(SvROK(sv));
 249
 250     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
 251 }
 252 PERL_STATIC_INLINE void
 253 Perl_SvAMAGIC_off(SV *sv)
 254 {
 255     PERL_ARGS_ASSERT_SVAMAGIC_OFF;
 256
 257     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
 258         HvAMAGIC_off(SvSTASH(SvRV(sv)));
 259 }
 260
 261 PERL_STATIC_INLINE U32
 262 Perl_SvPADSTALE_on(SV *sv)
 263 {
 264     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 265     return SvFLAGS(sv) |= SVs_PADSTALE;
 266 }
 267 PERL_STATIC_INLINE U32
 268 Perl_SvPADSTALE_off(SV *sv)
 269 {
 270     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 271     return SvFLAGS(sv) &= ~SVs_PADSTALE;
 272 }
 273 #if defined(PERL_CORE) || defined (PERL_EXT)
 274 PERL_STATIC_INLINE STRLEN
 275 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 276 {
 277     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
 278     if (SvGAMAGIC(sv)) {
 279         U8 *hopped = utf8_hop((U8 *)pv, pos);
 280         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
 281         return (STRLEN)(hopped - (U8 *)pv);
 282     }
 283     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
 284 }
 285 #endif
 286
 287 /* ------------------------------- handy.h ------------------------------- */
 288
 289 /* saves machine code for a common noreturn idiom typically used in Newx*() */
 290 GCC_DIAG_IGNORE_DECL(-Wunused-function);
 291 static void
 292 Perl_croak_memory_wrap(void)
 293 {
 294     Perl_croak_nocontext("%s",PL_memory_wrap);
 295 }
 296 GCC_DIAG_RESTORE_DECL;
 297
 298 /* ------------------------------- utf8.h ------------------------------- */
 299
 300 /*
 301 =head1 Unicode Support
 302 */
 303
 304 PERL_STATIC_INLINE void
 305 Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
 306 {
 307     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
 308      * encoded string at '*dest', updating '*dest' to include it */
 309
 310     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
 311
 312     if (NATIVE_BYTE_IS_INVARIANT(byte))
 313         *((*dest)++) = byte;
 314     else {
 315         *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
 316         *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
 317     }
 318 }
 319
 320 /*
 321 =for apidoc valid_utf8_to_uvchr
 322 Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
 323 known that the next character in the input UTF-8 string C<s> is well-formed
 324 (I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>.  Surrogates, non-character code
 325 points, and non-Unicode code points are allowed.
 326
 327 =cut
 328
 329  */
 330
 331 PERL_STATIC_INLINE UV
 332 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
 333 {
 334     const UV expectlen = UTF8SKIP(s);
 335     const U8* send = s + expectlen;
 336     UV uv = *s;
 337
 338     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
 339
 340     if (retlen) {
 341         *retlen = expectlen;
 342     }
 343
 344     /* An invariant is trivially returned */
 345     if (expectlen == 1) {
 346         return uv;
 347     }
 348
 349     /* Remove the leading bits that indicate the number of bytes, leaving just
 350      * the bits that are part of the value */
 351     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
 352
 353     /* Now, loop through the remaining bytes, accumulating each into the
 354      * working total as we go.  (I khw tried unrolling the loop for up to 4
 355      * bytes, but there was no performance improvement) */
 356     for (++s; s < send; s++) {
 357         uv = UTF8_ACCUMULATE(uv, *s);
 358     }
 359
 360     return UNI_TO_NATIVE(uv);
 361
 362 }
 363
 364 /*
 365 =for apidoc is_utf8_invariant_string
 366
 367 Returns TRUE if the first C<len> bytes of the string C<s> are the same
 368 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
 369 EBCDIC machines); otherwise it returns FALSE.  That is, it returns TRUE if they
 370 are UTF-8 invariant.  On ASCII-ish machines, all the ASCII characters and only
 371 the ASCII characters fit this definition.  On EBCDIC machines, the ASCII-range
 372 characters are invariant, but so also are the C1 controls.
 373
 374 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
 375 use this option, that C<s> can't have embedded C<NUL> characters and has to
 376 have a terminating C<NUL> byte).
 377
 378 See also
 379 C<L</is_utf8_string>>,
 380 C<L</is_utf8_string_flags>>,
 381 C<L</is_utf8_string_loc>>,
 382 C<L</is_utf8_string_loc_flags>>,
 383 C<L</is_utf8_string_loclen>>,
 384 C<L</is_utf8_string_loclen_flags>>,
 385 C<L</is_utf8_fixed_width_buf_flags>>,
 386 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 387 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 388 C<L</is_strict_utf8_string>>,
 389 C<L</is_strict_utf8_string_loc>>,
 390 C<L</is_strict_utf8_string_loclen>>,
 391 C<L</is_c9strict_utf8_string>>,
 392 C<L</is_c9strict_utf8_string_loc>>,
 393 and
 394 C<L</is_c9strict_utf8_string_loclen>>.
 395
 396 =cut
 397
 398 */
 399
 400 #define is_utf8_invariant_string(s, len)                                    \
 401                                 is_utf8_invariant_string_loc(s, len, NULL)
 402
 403 /*
 404 =for apidoc is_utf8_invariant_string_loc
 405
 406 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
 407 the first UTF-8 variant character in the C<ep> pointer; if all characters are
 408 UTF-8 invariant, this function does not change the contents of C<*ep>.
 409
 410 =cut
 411
 412 */
 413
 414 PERL_STATIC_INLINE bool
 415 Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
 416 {
 417     const U8* send;
 418     const U8* x = s;
 419
 420     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
 421
 422     if (len == 0) {
 423         len = strlen((const char *)s);
 424     }
 425
 426     send = s + len;
 427
 428 /* This looks like 0x010101... */
 429 #  define PERL_COUNT_MULTIPLIER   (~ (UINTMAX_C(0)) / 0xFF)
 430
 431 /* This looks like 0x808080... */
 432 #  define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
 433 #  define PERL_WORDSIZE            sizeof(PERL_UINTMAX_T)
 434 #  define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
 435
 436 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
 437  * or'ing together the lowest bits of 'x'.  Hopefully the final term gets
 438  * optimized out completely on a 32-bit system, and its mask gets optimized out
 439  * on a 64-bit system */
 440 #  define PERL_IS_SUBWORD_ADDR(x) (1 & (       PTR2nat(x)                     \
 441                                       |   (  PTR2nat(x) >> 1)                 \
 442                                       | ( ( (PTR2nat(x)                       \
 443                                            & PERL_WORD_BOUNDARY_MASK) >> 2))))
 444
 445 #ifndef EBCDIC
 446
 447     /* Do the word-at-a-time iff there is at least one usable full word.  That
 448      * means that after advancing to a word boundary, there still is at least a
 449      * full word left.  The number of bytes needed to advance is 'wordsize -
 450      * offset' unless offset is 0. */
 451     if ((STRLEN) (send - x) >= PERL_WORDSIZE
 452
 453                             /* This term is wordsize if subword; 0 if not */
 454                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
 455
 456                             /* 'offset' */
 457                           - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
 458     {
 459
 460         /* Process per-byte until reach word boundary.  XXX This loop could be
 461          * eliminated if we knew that this platform had fast unaligned reads */
 462         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
 463             if (! UTF8_IS_INVARIANT(*x)) {
 464                 if (ep) {
 465                     *ep = x;
 466                 }
 467
 468                 return FALSE;
 469             }
 470             x++;
 471         }
 472
 473         /* Here, we know we have at least one full word to process.  Process
 474          * per-word as long as we have at least a full word left */
 475         do {
 476             if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK)  {
 477
 478                 /* Found a variant.  Just return if caller doesn't want its
 479                  * exact position */
 480                 if (! ep) {
 481                     return FALSE;
 482                 }
 483
 484 #  if   BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    \
 485      || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
 486
 487                 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
 488                 assert(*ep >= s && *ep < send);
 489
 490                 return FALSE;
 491
 492 #  else   /* If weird byte order, drop into next loop to do byte-at-a-time
 493            checks. */
 494
 495                 break;
 496 #  endif
 497             }
 498
 499             x += PERL_WORDSIZE;
 500
 501         } while (x + PERL_WORDSIZE <= send);
 502     }
 503
 504 #endif      /* End of ! EBCDIC */
 505
 506     /* Process per-byte */
 507     while (x < send) {
 508         if (! UTF8_IS_INVARIANT(*x)) {
 509             if (ep) {
 510                 *ep = x;
 511             }
 512
 513             return FALSE;
 514         }
 515
 516         x++;
 517     }
 518
 519     return TRUE;
 520 }
 521
 522 #ifndef EBCDIC
 523
 524 PERL_STATIC_INLINE unsigned int
 525 Perl_variant_byte_number(PERL_UINTMAX_T word)
 526 {
 527
 528     /* This returns the position in a word (0..7) of the first variant byte in
 529      * it.  This is a helper function.  Note that there are no branches */
 530
 531     assert(word);
 532
 533     /* Get just the msb bits of each byte */
 534     word &= PERL_VARIANTS_WORD_MASK;
 535
 536 #  if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
 537
 538     /* Bytes are stored like
 539      *  Byte8 ... Byte2 Byte1
 540      *  63..56...15...8 7...0
 541      *
 542      *  Isolate the lsb;
 543      * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
 544      *
 545      * The word will look this this, with a rightmost set bit in position 's':
 546      * ('x's are don't cares)
 547      *      s
 548      *  x..x100..0
 549      *  x..xx10..0      Right shift (rightmost 0 is shifted off)
 550      *  x..xx01..1      Subtract 1, turns all the trailing zeros into 1's and
 551      *                  the 1 just to their left into a 0; the remainder is
 552      *                  untouched
 553      *  0..0011..1      The xor with the original, x..xx10..0, clears that
 554      *                  remainder, sets the bottom to all 1
 555      *  0..0100..0      Add 1 to clear the word except for the bit in 's'
 556      *
 557      * Another method is to do 'word &= -word'; but it generates a compiler
 558      * message on some platforms about taking the negative of an unsigned */
 559
 560     word >>= 1;
 561     word = 1 + (word ^ (word - 1));
 562
 563 #  elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
 564
 565     /* Bytes are stored like
 566      *  Byte1 Byte2  ... Byte8
 567      * 63..56 55..47 ... 7...0
 568      *
 569      * Isolate the msb; http://codeforces.com/blog/entry/10330
 570      *
 571      * Only the most significant set bit matters.  Or'ing word with its right
 572      * shift of 1 makes that bit and the next one to its right both 1.  Then
 573      * right shifting by 2 makes for 4 1-bits in a row. ...  We end with the
 574      * msb and all to the right being 1. */
 575     word |= word >>  1;
 576     word |= word >>  2;
 577     word |= word >>  4;
 578     word |= word >>  8;
 579     word |= word >> 16;
 580     word |= word >> 32;  /* This should get optimized out on 32-bit systems. */
 581
 582     /* Then subtracting the right shift by 1 clears all but the left-most of
 583      * the 1 bits, which is our desired result */
 584     word -= (word >> 1);
 585
 586 #  else
 587 #    error Unexpected byte order
 588 #  endif
 589
 590     /* Here 'word' has a single bit set: the  msb of the first byte in which it
 591      * is set.  Calculate that position in the word.  We can use this
 592      * specialized solution: https://stackoverflow.com/a/32339674/1626653,
 593      * assumes an 8-bit byte.  (On a 32-bit machine, the larger numbers should
 594      * just get shifted off at compile time) */
 595     word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
 596                         | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
 597                         |           (39 <<  24) |           (47 <<  16)
 598                         |           (55 <<   8) |           (63 <<   0));
 599     word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
 600
 601     /* Here, word contains the position 7..63 of that bit.  Convert to 0..7 */
 602     word = ((word + 1) >> 3) - 1;
 603
 604 #  if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
 605
 606     /* And invert the result */
 607     word = CHARBITS - word - 1;
 608
 609 #  endif
 610
 611     return (unsigned int) word;
 612 }
 613
 614 #endif
 615 #if defined(PERL_CORE) || defined(PERL_EXT)
 616
 617 /*
 618 =for apidoc variant_under_utf8_count
 619
 620 This function looks at the sequence of bytes between C<s> and C<e>, which are
 621 assumed to be encoded in ASCII/Latin1, and returns how many of them would
 622 change should the string be translated into UTF-8.  Due to the nature of UTF-8,
 623 each of these would occupy two bytes instead of the single one in the input
 624 string.  Thus, this function returns the precise number of bytes the string
 625 would expand by when translated to UTF-8.
 626
 627 Unlike most of the other functions that have C<utf8> in their name, the input
 628 to this function is NOT a UTF-8-encoded string.  The function name is slightly
 629 I<odd> to emphasize this.
 630
 631 This function is internal to Perl because khw thinks that any XS code that
 632 would want this is probably operating too close to the internals.  Presenting a
 633 valid use case could change that.
 634
 635 See also
 636 C<L<perlapi/is_utf8_invariant_string>>
 637 and
 638 C<L<perlapi/is_utf8_invariant_string_loc>>,
 639
 640 =cut
 641
 642 */
 643
 644 PERL_STATIC_INLINE Size_t
 645 S_variant_under_utf8_count(const U8* const s, const U8* const e)
 646 {
 647     const U8* x = s;
 648     Size_t count = 0;
 649
 650     PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
 651
 652 #  ifndef EBCDIC
 653
 654     /* Test if the string is long enough to use word-at-a-time.  (Logic is the
 655      * same as for is_utf8_invariant_string()) */
 656     if ((STRLEN) (e - x) >= PERL_WORDSIZE
 657                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
 658                           - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
 659     {
 660
 661         /* Process per-byte until reach word boundary.  XXX This loop could be
 662          * eliminated if we knew that this platform had fast unaligned reads */
 663         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
 664             count += ! UTF8_IS_INVARIANT(*x++);
 665         }
 666
 667         /* Process per-word as long as we have at least a full word left */
 668         do {    /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
 669                    explanation of how this works */
 670             PERL_UINTMAX_T increment
 671                 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
 672                       * PERL_COUNT_MULTIPLIER)
 673                     >> ((PERL_WORDSIZE - 1) * CHARBITS);
 674             count += (Size_t) increment;
 675             x += PERL_WORDSIZE;
 676         } while (x + PERL_WORDSIZE <= e);
 677     }
 678
 679 #  endif
 680
 681     /* Process per-byte */
 682     while (x < e) {
 683         if (! UTF8_IS_INVARIANT(*x)) {
 684             count++;
 685         }
 686
 687         x++;
 688     }
 689
 690     return count;
 691 }
 692
 693 #endif
 694
 695 #ifndef PERL_IN_REGEXEC_C   /* Keep  these around for that file */
 696 #  undef PERL_WORDSIZE
 697 #  undef PERL_COUNT_MULTIPLIER
 698 #  undef PERL_WORD_BOUNDARY_MASK
 699 #  undef PERL_VARIANTS_WORD_MASK
 700 #endif
 701
 702 /*
 703 =for apidoc is_utf8_string
 704
 705 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 706 Perl-extended-UTF-8 string; returns FALSE otherwise.  If C<len> is 0, it will
 707 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
 708 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
 709 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
 710
 711 This function considers Perl's extended UTF-8 to be valid.  That means that
 712 code points above Unicode, surrogates, and non-character code points are
 713 considered valid by this function.  Use C<L</is_strict_utf8_string>>,
 714 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
 715 code points are considered valid.
 716
 717 See also
 718 C<L</is_utf8_invariant_string>>,
 719 C<L</is_utf8_invariant_string_loc>>,
 720 C<L</is_utf8_string_loc>>,
 721 C<L</is_utf8_string_loclen>>,
 722 C<L</is_utf8_fixed_width_buf_flags>>,
 723 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 724 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 725
 726 =cut
 727 */
 728
 729 #define is_utf8_string(s, len)  is_utf8_string_loclen(s, len, NULL, NULL)
 730
 731 #if defined(PERL_CORE) || defined (PERL_EXT)
 732
 733 /*
 734 =for apidoc is_utf8_non_invariant_string
 735
 736 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
 737 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
 738 UTF-8; otherwise returns FALSE.
 739
 740 A TRUE return means that at least one code point represented by the sequence
 741 either is a wide character not representable as a single byte, or the
 742 representation differs depending on whether the sequence is encoded in UTF-8 or
 743 not.
 744
 745 See also
 746 C<L<perlapi/is_utf8_invariant_string>>,
 747 C<L<perlapi/is_utf8_string>>
 748
 749 =cut
 750
 751 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
 752 It generally needn't be if its string is entirely UTF-8 invariant, and it
 753 shouldn't be if it otherwise contains invalid UTF-8.
 754
 755 It is an internal function because khw thinks that XS code shouldn't be working
 756 at this low a level.  A valid use case could change that.
 757
 758 */
 759
 760 PERL_STATIC_INLINE bool
 761 Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
 762 {
 763     const U8 * first_variant;
 764
 765     PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
 766
 767     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 768         return FALSE;
 769     }
 770
 771     return is_utf8_string(first_variant, len - (first_variant - s));
 772 }
 773
 774 #endif
 775
 776 /*
 777 =for apidoc is_strict_utf8_string
 778
 779 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 780 UTF-8-encoded string that is fully interchangeable by any application using
 781 Unicode rules; otherwise it returns FALSE.  If C<len> is 0, it will be
 782 calculated using C<strlen(s)> (which means if you use this option, that C<s>
 783 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
 784 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
 785
 786 This function returns FALSE for strings containing any
 787 code points above the Unicode max of 0x10FFFF, surrogate code points, or
 788 non-character code points.
 789
 790 See also
 791 C<L</is_utf8_invariant_string>>,
 792 C<L</is_utf8_invariant_string_loc>>,
 793 C<L</is_utf8_string>>,
 794 C<L</is_utf8_string_flags>>,
 795 C<L</is_utf8_string_loc>>,
 796 C<L</is_utf8_string_loc_flags>>,
 797 C<L</is_utf8_string_loclen>>,
 798 C<L</is_utf8_string_loclen_flags>>,
 799 C<L</is_utf8_fixed_width_buf_flags>>,
 800 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 801 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 802 C<L</is_strict_utf8_string_loc>>,
 803 C<L</is_strict_utf8_string_loclen>>,
 804 C<L</is_c9strict_utf8_string>>,
 805 C<L</is_c9strict_utf8_string_loc>>,
 806 and
 807 C<L</is_c9strict_utf8_string_loclen>>.
 808
 809 =cut
 810 */
 811
 812 #define is_strict_utf8_string(s, len)  is_strict_utf8_string_loclen(s, len, NULL, NULL)
 813
 814 /*
 815 =for apidoc is_c9strict_utf8_string
 816
 817 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 818 UTF-8-encoded string that conforms to
 819 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
 820 otherwise it returns FALSE.  If C<len> is 0, it will be calculated using
 821 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
 822 C<NUL> characters and has to have a terminating C<NUL> byte).  Note that all
 823 characters being ASCII constitute 'a valid UTF-8 string'.
 824
 825 This function returns FALSE for strings containing any code points above the
 826 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
 827 code points per
 828 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
 829
 830 See also
 831 C<L</is_utf8_invariant_string>>,
 832 C<L</is_utf8_invariant_string_loc>>,
 833 C<L</is_utf8_string>>,
 834 C<L</is_utf8_string_flags>>,
 835 C<L</is_utf8_string_loc>>,
 836 C<L</is_utf8_string_loc_flags>>,
 837 C<L</is_utf8_string_loclen>>,
 838 C<L</is_utf8_string_loclen_flags>>,
 839 C<L</is_utf8_fixed_width_buf_flags>>,
 840 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 841 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 842 C<L</is_strict_utf8_string>>,
 843 C<L</is_strict_utf8_string_loc>>,
 844 C<L</is_strict_utf8_string_loclen>>,
 845 C<L</is_c9strict_utf8_string_loc>>,
 846 and
 847 C<L</is_c9strict_utf8_string_loclen>>.
 848
 849 =cut
 850 */
 851
 852 #define is_c9strict_utf8_string(s, len)  is_c9strict_utf8_string_loclen(s, len, NULL, 0)
 853
 854 /*
 855 =for apidoc is_utf8_string_flags
 856
 857 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 858 UTF-8 string, subject to the restrictions imposed by C<flags>;
 859 returns FALSE otherwise.  If C<len> is 0, it will be calculated
 860 using C<strlen(s)> (which means if you use this option, that C<s> can't have
 861 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
 862 that all characters being ASCII constitute 'a valid UTF-8 string'.
 863
 864 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
 865 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
 866 as C<L</is_strict_utf8_string>>; and if C<flags> is
 867 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
 868 C<L</is_c9strict_utf8_string>>.  Otherwise C<flags> may be any
 869 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
 870 C<L</utf8n_to_uvchr>>, with the same meanings.
 871
 872 See also
 873 C<L</is_utf8_invariant_string>>,
 874 C<L</is_utf8_invariant_string_loc>>,
 875 C<L</is_utf8_string>>,
 876 C<L</is_utf8_string_loc>>,
 877 C<L</is_utf8_string_loc_flags>>,
 878 C<L</is_utf8_string_loclen>>,
 879 C<L</is_utf8_string_loclen_flags>>,
 880 C<L</is_utf8_fixed_width_buf_flags>>,
 881 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 882 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 883 C<L</is_strict_utf8_string>>,
 884 C<L</is_strict_utf8_string_loc>>,
 885 C<L</is_strict_utf8_string_loclen>>,
 886 C<L</is_c9strict_utf8_string>>,
 887 C<L</is_c9strict_utf8_string_loc>>,
 888 and
 889 C<L</is_c9strict_utf8_string_loclen>>.
 890
 891 =cut
 892 */
 893
 894 PERL_STATIC_INLINE bool
 895 Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
 896 {
 897     const U8 * first_variant;
 898
 899     PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
 900     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
 901                           |UTF8_DISALLOW_PERL_EXTENDED)));
 902
 903     if (len == 0) {
 904         len = strlen((const char *)s);
 905     }
 906
 907     if (flags == 0) {
 908         return is_utf8_string(s, len);
 909     }
 910
 911     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 912                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
 913     {
 914         return is_strict_utf8_string(s, len);
 915     }
 916
 917     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 918                                        == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
 919     {
 920         return is_c9strict_utf8_string(s, len);
 921     }
 922
 923     if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
 924         const U8* const send = s + len;
 925         const U8* x = first_variant;
 926
 927         while (x < send) {
 928             STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
 929             if (UNLIKELY(! cur_len)) {
 930                 return FALSE;
 931             }
 932             x += cur_len;
 933         }
 934     }
 935
 936     return TRUE;
 937 }
 938
 939 /*
 940
 941 =for apidoc is_utf8_string_loc
 942
 943 Like C<L</is_utf8_string>> but stores the location of the failure (in the
 944 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 945 "utf8ness success") in the C<ep> pointer.
 946
 947 See also C<L</is_utf8_string_loclen>>.
 948
 949 =cut
 950 */
 951
 952 #define is_utf8_string_loc(s, len, ep)  is_utf8_string_loclen(s, len, ep, 0)
 953
 954 /*
 955
 956 =for apidoc is_utf8_string_loclen
 957
 958 Like C<L</is_utf8_string>> but stores the location of the failure (in the
 959 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 960 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
 961 encoded characters in the C<el> pointer.
 962
 963 See also C<L</is_utf8_string_loc>>.
 964
 965 =cut
 966 */
 967
 968 PERL_STATIC_INLINE bool
 969 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 970 {
 971     const U8 * first_variant;
 972
 973     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 974
 975     if (len == 0) {
 976         len = strlen((const char *) s);
 977     }
 978
 979     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 980         if (el)
 981             *el = len;
 982
 983         if (ep) {
 984             *ep = s + len;
 985         }
 986
 987         return TRUE;
 988     }
 989
 990     {
 991         const U8* const send = s + len;
 992         const U8* x = first_variant;
 993         STRLEN outlen = first_variant - s;
 994
 995         while (x < send) {
 996             const STRLEN cur_len = isUTF8_CHAR(x, send);
 997             if (UNLIKELY(! cur_len)) {
 998                 break;
 999             }
1000             x += cur_len;
1001             outlen++;
1002         }
1003
1004         if (el)
1005             *el = outlen;
1006
1007         if (ep) {
1008             *ep = x;
1009         }
1010
1011         return (x == send);
1012     }
1013 }
1014
1015 /*
1016
1017 =for apidoc isUTF8_CHAR
1018
1019 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1020 looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1021 that represents some code point; otherwise it evaluates to 0.  If non-zero, the
1022 value gives how many bytes starting at C<s> comprise the code point's
1023 representation.  Any bytes remaining before C<e>, but beyond the ones needed to
1024 form the first code point in C<s>, are not examined.
1025
1026 The code point can be any that will fit in an IV on this machine, using Perl's
1027 extension to official UTF-8 to represent those higher than the Unicode maximum
1028 of 0x10FFFF.  That means that this macro is used to efficiently decide if the
1029 next few bytes in C<s> is legal UTF-8 for a single character.
1030
1031 Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1032 defined by Unicode to be fully interchangeable across applications;
1033 C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1034 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1035 code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1036
1037 Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1038 C<L</is_utf8_string_loclen>> to check entire strings.
1039
1040 Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1041 machines) is a valid UTF-8 character.
1042
1043 =cut
1044
1045 This uses an adaptation of the table and algorithm given in
1046 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1047 documentation of the original version.  A copyright notice for the original
1048 version is given at the beginning of this file.  The Perl adapation is
1049 documented at the definition of PL_extended_utf8_dfa_tab[].
1050
1051 */
1052
1053 PERL_STATIC_INLINE Size_t
1054 Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
1055 {
1056     const U8 * s = s0;
1057     UV state = 0;
1058
1059     PERL_ARGS_ASSERT_ISUTF8_CHAR;
1060
1061     /* This dfa is fast.  If it accepts the input, it was for a well-formed,
1062      * code point, which can be returned immediately.  Otherwise, it is either
1063      * malformed, or for the start byte FF which the dfa doesn't handle (except
1064      * on 32-bit ASCII platforms where it trivially is an error).  Call a
1065      * helper function for the other platforms. */
1066
1067     while (s < e && LIKELY(state != 1)) {
1068         state = PL_extended_utf8_dfa_tab[256
1069                                          + state
1070                                          + PL_extended_utf8_dfa_tab[*s]];
1071         if (state != 0) {
1072             s++;
1073             continue;
1074         }
1075
1076         return s - s0 + 1;
1077     }
1078
1079 #if defined(UV_IS_QUAD) || defined(EBCDIC)
1080
1081     if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1082        return is_utf8_char_helper(s0, e, 0);
1083     }
1084
1085 #endif
1086
1087     return 0;
1088 }
1089
1090 /*
1091
1092 =for apidoc isSTRICT_UTF8_CHAR
1093
1094 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1095 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1096 Unicode code point completely acceptable for open interchange between all
1097 applications; otherwise it evaluates to 0.  If non-zero, the value gives how
1098 many bytes starting at C<s> comprise the code point's representation.  Any
1099 bytes remaining before C<e>, but beyond the ones needed to form the first code
1100 point in C<s>, are not examined.
1101
1102 The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1103 be a surrogate nor a non-character code point.  Thus this excludes any code
1104 point from Perl's extended UTF-8.
1105
1106 This is used to efficiently decide if the next few bytes in C<s> is
1107 legal Unicode-acceptable UTF-8 for a single character.
1108
1109 Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1110 #9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1111 code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1112 and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1113
1114 Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1115 C<L</is_strict_utf8_string_loclen>> to check entire strings.
1116
1117 =cut
1118
1119 This uses an adaptation of the tables and algorithm given in
1120 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1121 documentation of the original version.  A copyright notice for the original
1122 version is given at the beginning of this file.  The Perl adapation is
1123 documented at the definition of strict_extended_utf8_dfa_tab[].
1124
1125 */
1126
1127 PERL_STATIC_INLINE Size_t
1128 Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1129 {
1130     const U8 * s = s0;
1131     UV state = 0;
1132
1133     PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1134
1135     while (s < e && LIKELY(state != 1)) {
1136         state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
1137
1138         if (state != 0) {
1139             s++;
1140             continue;
1141         }
1142
1143         return s - s0 + 1;
1144     }
1145
1146 #ifndef EBCDIC
1147
1148     /* The dfa above drops out for certain Hanguls; handle them specially */
1149     if (is_HANGUL_ED_utf8_safe(s0, e)) {
1150         return 3;
1151     }
1152
1153 #endif
1154
1155     return 0;
1156 }
1157
1158 /*
1159
1160 =for apidoc isC9_STRICT_UTF8_CHAR
1161
1162 Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1163 looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1164 Unicode non-surrogate code point; otherwise it evaluates to 0.  If non-zero,
1165 the value gives how many bytes starting at C<s> comprise the code point's
1166 representation.  Any bytes remaining before C<e>, but beyond the ones needed to
1167 form the first code point in C<s>, are not examined.
1168
1169 The largest acceptable code point is the Unicode maximum 0x10FFFF.  This
1170 differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1171 code points.  This corresponds to
1172 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1173 which said that non-character code points are merely discouraged rather than
1174 completely forbidden in open interchange.  See
1175 L<perlunicode/Noncharacter code points>.
1176
1177 Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1178 C<L</isUTF8_CHAR_flags>> for a more customized definition.
1179
1180 Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1181 C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1182
1183 =cut
1184
1185 This uses an adaptation of the tables and algorithm given in
1186 https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1187 documentation of the original version.  A copyright notice for the original
1188 version is given at the beginning of this file.  The Perl adapation is
1189 documented at the definition of PL_c9_utf8_dfa_tab[].
1190
1191 */
1192
1193 PERL_STATIC_INLINE Size_t
1194 Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
1195 {
1196     const U8 * s = s0;
1197     UV state = 0;
1198
1199     PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1200
1201     while (s < e && LIKELY(state != 1)) {
1202         state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
1203
1204         if (state != 0) {
1205             s++;
1206             continue;
1207         }
1208
1209         return s - s0 + 1;
1210     }
1211
1212     return 0;
1213 }
1214
1215 /*
1216
1217 =for apidoc is_strict_utf8_string_loc
1218
1219 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1220 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1221 "utf8ness success") in the C<ep> pointer.
1222
1223 See also C<L</is_strict_utf8_string_loclen>>.
1224
1225 =cut
1226 */
1227
1228 #define is_strict_utf8_string_loc(s, len, ep)                               \
1229                                 is_strict_utf8_string_loclen(s, len, ep, 0)
1230
1231 /*
1232
1233 =for apidoc is_strict_utf8_string_loclen
1234
1235 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1236 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1237 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1238 encoded characters in the C<el> pointer.
1239
1240 See also C<L</is_strict_utf8_string_loc>>.
1241
1242 =cut
1243 */
1244
1245 PERL_STATIC_INLINE bool
1246 Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1247 {
1248     const U8 * first_variant;
1249
1250     PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1251
1252     if (len == 0) {
1253         len = strlen((const char *) s);
1254     }
1255
1256     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1257         if (el)
1258             *el = len;
1259
1260         if (ep) {
1261             *ep = s + len;
1262         }
1263
1264         return TRUE;
1265     }
1266
1267     {
1268         const U8* const send = s + len;
1269         const U8* x = first_variant;
1270         STRLEN outlen = first_variant - s;
1271
1272         while (x < send) {
1273             const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1274             if (UNLIKELY(! cur_len)) {
1275                 break;
1276             }
1277             x += cur_len;
1278             outlen++;
1279         }
1280
1281         if (el)
1282             *el = outlen;
1283
1284         if (ep) {
1285             *ep = x;
1286         }
1287
1288         return (x == send);
1289     }
1290 }
1291
1292 /*
1293
1294 =for apidoc is_c9strict_utf8_string_loc
1295
1296 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1297 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1298 "utf8ness success") in the C<ep> pointer.
1299
1300 See also C<L</is_c9strict_utf8_string_loclen>>.
1301
1302 =cut
1303 */
1304
1305 #define is_c9strict_utf8_string_loc(s, len, ep)                             \
1306                             is_c9strict_utf8_string_loclen(s, len, ep, 0)
1307
1308 /*
1309
1310 =for apidoc is_c9strict_utf8_string_loclen
1311
1312 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1313 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1314 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1315 characters in the C<el> pointer.
1316
1317 See also C<L</is_c9strict_utf8_string_loc>>.
1318
1319 =cut
1320 */
1321
1322 PERL_STATIC_INLINE bool
1323 Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1324 {
1325     const U8 * first_variant;
1326
1327     PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1328
1329     if (len == 0) {
1330         len = strlen((const char *) s);
1331     }
1332
1333     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1334         if (el)
1335             *el = len;
1336
1337         if (ep) {
1338             *ep = s + len;
1339         }
1340
1341         return TRUE;
1342     }
1343
1344     {
1345         const U8* const send = s + len;
1346         const U8* x = first_variant;
1347         STRLEN outlen = first_variant - s;
1348
1349         while (x < send) {
1350             const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1351             if (UNLIKELY(! cur_len)) {
1352                 break;
1353             }
1354             x += cur_len;
1355             outlen++;
1356         }
1357
1358         if (el)
1359             *el = outlen;
1360
1361         if (ep) {
1362             *ep = x;
1363         }
1364
1365         return (x == send);
1366     }
1367 }
1368
1369 /*
1370
1371 =for apidoc is_utf8_string_loc_flags
1372
1373 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1374 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1375 "utf8ness success") in the C<ep> pointer.
1376
1377 See also C<L</is_utf8_string_loclen_flags>>.
1378
1379 =cut
1380 */
1381
1382 #define is_utf8_string_loc_flags(s, len, ep, flags)                         \
1383                         is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1384
1385
1386 /* The above 3 actual functions could have been moved into the more general one
1387  * just below, and made #defines that call it with the right 'flags'.  They are
1388  * currently kept separate to increase their chances of getting inlined */
1389
1390 /*
1391
1392 =for apidoc is_utf8_string_loclen_flags
1393
1394 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1395 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1396 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1397 encoded characters in the C<el> pointer.
1398
1399 See also C<L</is_utf8_string_loc_flags>>.
1400
1401 =cut
1402 */
1403
1404 PERL_STATIC_INLINE bool
1405 Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1406 {
1407     const U8 * first_variant;
1408
1409     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1410     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1411                           |UTF8_DISALLOW_PERL_EXTENDED)));
1412
1413     if (len == 0) {
1414         len = strlen((const char *) s);
1415     }
1416
1417     if (flags == 0) {
1418         return is_utf8_string_loclen(s, len, ep, el);
1419     }
1420
1421     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1422                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1423     {
1424         return is_strict_utf8_string_loclen(s, len, ep, el);
1425     }
1426
1427     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1428                                     == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1429     {
1430         return is_c9strict_utf8_string_loclen(s, len, ep, el);
1431     }
1432
1433     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1434         if (el)
1435             *el = len;
1436
1437         if (ep) {
1438             *ep = s + len;
1439         }
1440
1441         return TRUE;
1442     }
1443
1444     {
1445         const U8* send = s + len;
1446         const U8* x = first_variant;
1447         STRLEN outlen = first_variant - s;
1448
1449         while (x < send) {
1450             const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1451             if (UNLIKELY(! cur_len)) {
1452                 break;
1453             }
1454             x += cur_len;
1455             outlen++;
1456         }
1457
1458         if (el)
1459             *el = outlen;
1460
1461         if (ep) {
1462             *ep = x;
1463         }
1464
1465         return (x == send);
1466     }
1467 }
1468
1469 /*
1470 =for apidoc utf8_distance
1471
1472 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1473 and C<b>.
1474
1475 WARNING: use only if you *know* that the pointers point inside the
1476 same UTF-8 buffer.
1477
1478 =cut
1479 */
1480
1481 PERL_STATIC_INLINE IV
1482 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1483 {
1484     PERL_ARGS_ASSERT_UTF8_DISTANCE;
1485
1486     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1487 }
1488
1489 /*
1490 =for apidoc utf8_hop
1491
1492 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1493 forward or backward.
1494
1495 WARNING: do not use the following unless you *know* C<off> is within
1496 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1497 on the first byte of character or just after the last byte of a character.
1498
1499 =cut
1500 */
1501
1502 PERL_STATIC_INLINE U8 *
1503 Perl_utf8_hop(const U8 *s, SSize_t off)
1504 {
1505     PERL_ARGS_ASSERT_UTF8_HOP;
1506
1507     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1508      * the bitops (especially ~) can create illegal UTF-8.
1509      * In other words: in Perl UTF-8 is not just for Unicode. */
1510
1511     if (off >= 0) {
1512         while (off--)
1513             s += UTF8SKIP(s);
1514     }
1515     else {
1516         while (off++) {
1517             s--;
1518             while (UTF8_IS_CONTINUATION(*s))
1519                 s--;
1520         }
1521     }
1522     GCC_DIAG_IGNORE(-Wcast-qual)
1523     return (U8 *)s;
1524     GCC_DIAG_RESTORE
1525 }
1526
1527 /*
1528 =for apidoc utf8_hop_forward
1529
1530 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1531 forward.
1532
1533 C<off> must be non-negative.
1534
1535 C<s> must be before or equal to C<end>.
1536
1537 When moving forward it will not move beyond C<end>.
1538
1539 Will not exceed this limit even if the string is not valid "UTF-8".
1540
1541 =cut
1542 */
1543
1544 PERL_STATIC_INLINE U8 *
1545 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1546 {
1547     PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1548
1549     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1550      * the bitops (especially ~) can create illegal UTF-8.
1551      * In other words: in Perl UTF-8 is not just for Unicode. */
1552
1553     assert(s <= end);
1554     assert(off >= 0);
1555
1556     while (off--) {
1557         STRLEN skip = UTF8SKIP(s);
1558         if ((STRLEN)(end - s) <= skip) {
1559             GCC_DIAG_IGNORE(-Wcast-qual)
1560             return (U8 *)end;
1561             GCC_DIAG_RESTORE
1562         }
1563         s += skip;
1564     }
1565
1566     GCC_DIAG_IGNORE(-Wcast-qual)
1567     return (U8 *)s;
1568     GCC_DIAG_RESTORE
1569 }
1570
1571 /*
1572 =for apidoc utf8_hop_back
1573
1574 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1575 backward.
1576
1577 C<off> must be non-positive.
1578
1579 C<s> must be after or equal to C<start>.
1580
1581 When moving backward it will not move before C<start>.
1582
1583 Will not exceed this limit even if the string is not valid "UTF-8".
1584
1585 =cut
1586 */
1587
1588 PERL_STATIC_INLINE U8 *
1589 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1590 {
1591     PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1592
1593     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1594      * the bitops (especially ~) can create illegal UTF-8.
1595      * In other words: in Perl UTF-8 is not just for Unicode. */
1596
1597     assert(start <= s);
1598     assert(off <= 0);
1599
1600     while (off++ && s > start) {
1601         do {
1602             s--;
1603         } while (UTF8_IS_CONTINUATION(*s) && s > start);
1604     }
1605
1606     GCC_DIAG_IGNORE(-Wcast-qual)
1607     return (U8 *)s;
1608     GCC_DIAG_RESTORE
1609 }
1610
1611 /*
1612 =for apidoc utf8_hop_safe
1613
1614 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1615 either forward or backward.
1616
1617 When moving backward it will not move before C<start>.
1618
1619 When moving forward it will not move beyond C<end>.
1620
1621 Will not exceed those limits even if the string is not valid "UTF-8".
1622
1623 =cut
1624 */
1625
1626 PERL_STATIC_INLINE U8 *
1627 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1628 {
1629     PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1630
1631     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1632      * the bitops (especially ~) can create illegal UTF-8.
1633      * In other words: in Perl UTF-8 is not just for Unicode. */
1634
1635     assert(start <= s && s <= end);
1636
1637     if (off >= 0) {
1638         return utf8_hop_forward(s, off, end);
1639     }
1640     else {
1641         return utf8_hop_back(s, off, start);
1642     }
1643 }
1644
1645 /*
1646
1647 =for apidoc is_utf8_valid_partial_char
1648
1649 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1650 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1651 points.  Otherwise, it returns 1 if there exists at least one non-empty
1652 sequence of bytes that when appended to sequence C<s>, starting at position
1653 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1654 otherwise returns 0.
1655
1656 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1657 point.
1658
1659 This is useful when a fixed-length buffer is being tested for being well-formed
1660 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1661 it is split somewhere in the middle of the final code point's UTF-8
1662 representation.  (Presumably when the buffer is refreshed with the next chunk
1663 of data, the new first bytes will complete the partial code point.)   This
1664 function is used to verify that the final bytes in the current buffer are in
1665 fact the legal beginning of some code point, so that if they aren't, the
1666 failure can be signalled without having to wait for the next read.
1667
1668 =cut
1669 */
1670 #define is_utf8_valid_partial_char(s, e)                                    \
1671                                 is_utf8_valid_partial_char_flags(s, e, 0)
1672
1673 /*
1674
1675 =for apidoc is_utf8_valid_partial_char_flags
1676
1677 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1678 or not the input is a valid UTF-8 encoded partial character, but it takes an
1679 extra parameter, C<flags>, which can further restrict which code points are
1680 considered valid.
1681
1682 If C<flags> is 0, this behaves identically to
1683 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
1684 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
1685 there is any sequence of bytes that can complete the input partial character in
1686 such a way that a non-prohibited character is formed, the function returns
1687 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
1688 partial character input.  But many  of the other possible excluded types can be
1689 determined from just the first one or two bytes.
1690
1691 =cut
1692  */
1693
1694 PERL_STATIC_INLINE bool
1695 Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1696 {
1697     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1698
1699     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1700                           |UTF8_DISALLOW_PERL_EXTENDED)));
1701
1702     if (s >= e || s + UTF8SKIP(s) <= e) {
1703         return FALSE;
1704     }
1705
1706     return cBOOL(is_utf8_char_helper(s, e, flags));
1707 }
1708
1709 /*
1710
1711 =for apidoc is_utf8_fixed_width_buf_flags
1712
1713 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1714 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1715 otherwise it returns FALSE.
1716
1717 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1718 without restriction.  If the final few bytes of the buffer do not form a
1719 complete code point, this will return TRUE anyway, provided that
1720 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1721
1722 If C<flags> in non-zero, it can be any combination of the
1723 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1724 same meanings.
1725
1726 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1727 returns FALSE if the final few bytes of the string don't form a complete code
1728 point.
1729
1730 =cut
1731  */
1732 #define is_utf8_fixed_width_buf_flags(s, len, flags)                        \
1733                 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1734
1735 /*
1736
1737 =for apidoc is_utf8_fixed_width_buf_loc_flags
1738
1739 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1740 failure in the C<ep> pointer.  If the function returns TRUE, C<*ep> will point
1741 to the beginning of any partial character at the end of the buffer; if there is
1742 no partial character C<*ep> will contain C<s>+C<len>.
1743
1744 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1745
1746 =cut
1747 */
1748
1749 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)               \
1750                 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1751
1752 /*
1753
1754 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1755
1756 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1757 complete, valid characters found in the C<el> pointer.
1758
1759 =cut
1760 */
1761
1762 PERL_STATIC_INLINE bool
1763 Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1764                                        STRLEN len,
1765                                        const U8 **ep,
1766                                        STRLEN *el,
1767                                        const U32 flags)
1768 {
1769     const U8 * maybe_partial;
1770
1771     PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1772
1773     if (! ep) {
1774         ep  = &maybe_partial;
1775     }
1776
1777     /* If it's entirely valid, return that; otherwise see if the only error is
1778      * that the final few bytes are for a partial character */
1779     return    is_utf8_string_loclen_flags(s, len, ep, el, flags)
1780            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1781 }
1782
1783 PERL_STATIC_INLINE UV
1784 Perl_utf8n_to_uvchr_msgs(const U8 *s,
1785                       STRLEN curlen,
1786                       STRLEN *retlen,
1787                       const U32 flags,
1788                       U32 * errors,
1789                       AV ** msgs)
1790 {
1791     /* This is the inlined portion of utf8n_to_uvchr_msgs.  It handles the
1792      * simple cases, and, if necessary calls a helper function to deal with the
1793      * more complex ones.  Almost all well-formed non-problematic code points
1794      * are considered simple, so that it's unlikely that the helper function
1795      * will need to be called.
1796      *
1797      * This is an adaptation of the tables and algorithm given in
1798      * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1799      * comprehensive documentation of the original version.  A copyright notice
1800      * for the original version is given at the beginning of this file.  The
1801      * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
1802      */
1803
1804     const U8 * const s0 = s;
1805     const U8 * send = s0 + curlen;
1806     UV uv = 0;      /* The 0 silences some stupid compilers */
1807     UV state = 0;
1808
1809     PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1810
1811     /* This dfa is fast.  If it accepts the input, it was for a well-formed,
1812      * non-problematic code point, which can be returned immediately.
1813      * Otherwise we call a helper function to figure out the more complicated
1814      * cases. */
1815
1816     while (s < send && LIKELY(state != 1)) {
1817         UV type = PL_strict_utf8_dfa_tab[*s];
1818
1819         uv = (state == 0)
1820              ?  ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1821              : UTF8_ACCUMULATE(uv, *s);
1822         state = PL_strict_utf8_dfa_tab[256 + state + type];
1823
1824         if (state != 0) {
1825             s++;
1826             continue;
1827         }
1828
1829         if (retlen) {
1830             *retlen = s - s0 + 1;
1831         }
1832         if (errors) {
1833             *errors = 0;
1834         }
1835         if (msgs) {
1836             *msgs = NULL;
1837         }
1838
1839         return UNI_TO_NATIVE(uv);
1840     }
1841
1842     /* Here is potentially problematic.  Use the full mechanism */
1843     return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1844 }
1845
1846 PERL_STATIC_INLINE UV
1847 Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
1848 {
1849     PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
1850
1851     assert(s < send);
1852
1853     if (! ckWARN_d(WARN_UTF8)) {
1854
1855         /* EMPTY is not really allowed, and asserts on debugging builds.  But
1856          * on non-debugging we have to deal with it, and this causes it to
1857          * return the REPLACEMENT CHARACTER, as the documentation indicates */
1858         return utf8n_to_uvchr(s, send - s, retlen,
1859                               (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
1860     }
1861     else {
1862         UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1863         if (retlen && ret == 0 && *s != '\0') {
1864             *retlen = (STRLEN) -1;
1865         }
1866
1867         return ret;
1868     }
1869 }
1870
1871 /* ------------------------------- perl.h ----------------------------- */
1872
1873 /*
1874 =head1 Miscellaneous Functions
1875
1876 =for apidoc is_safe_syscall
1877
1878 Test that the given C<pv> (with length C<len>) doesn't contain any internal
1879 C<NUL> characters.
1880 If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
1881 category, and return FALSE.
1882
1883 Return TRUE if the name is safe.
1884
1885 C<what> and C<op_name> are used in any warning.
1886
1887 Used by the C<IS_SAFE_SYSCALL()> macro.
1888
1889 =cut
1890 */
1891
1892 PERL_STATIC_INLINE bool
1893 Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
1894 {
1895     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1896      * perl itself uses xce*() functions which accept 8-bit strings.
1897      */
1898
1899     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1900
1901     if (len > 1) {
1902         char *null_at;
1903         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1904                 SETERRNO(ENOENT, LIB_INVARG);
1905                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1906                                    "Invalid \\0 character in %s for %s: %s\\0%s",
1907                                    what, op_name, pv, null_at+1);
1908                 return FALSE;
1909         }
1910     }
1911
1912     return TRUE;
1913 }
1914
1915 /*
1916
1917 Return true if the supplied filename has a newline character
1918 immediately before the first (hopefully only) NUL.
1919
1920 My original look at this incorrectly used the len from SvPV(), but
1921 that's incorrect, since we allow for a NUL in pv[len-1].
1922
1923 So instead, strlen() and work from there.
1924
1925 This allow for the user reading a filename, forgetting to chomp it,
1926 then calling:
1927
1928   open my $foo, "$file\0";
1929
1930 */
1931
1932 #ifdef PERL_CORE
1933
1934 PERL_STATIC_INLINE bool
1935 S_should_warn_nl(const char *pv)
1936 {
1937     STRLEN len;
1938
1939     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1940
1941     len = strlen(pv);
1942
1943     return len > 0 && pv[len-1] == '\n';
1944 }
1945
1946 #endif
1947
1948 #if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1949
1950 PERL_STATIC_INLINE bool
1951 S_lossless_NV_to_IV(const NV nv, IV *ivp)
1952 {
1953     /* This function determines if the input NV 'nv' may be converted without
1954      * loss of data to an IV.  If not, it returns FALSE taking no other action.
1955      * But if it is possible, it does the conversion, returning TRUE, and
1956      * storing the converted result in '*ivp' */
1957
1958     PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1959
1960 #  if  defined(Perl_isnan)
1961
1962     if (UNLIKELY(Perl_isnan(nv))) {
1963         return FALSE;
1964     }
1965
1966 #  endif
1967
1968     if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
1969         return FALSE;
1970     }
1971
1972     if ((IV) nv != nv) {
1973         return FALSE;
1974     }
1975
1976     *ivp = (IV) nv;
1977     return TRUE;
1978 }
1979
1980 #endif
1981
1982 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1983
1984 #if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
1985
1986 #define MAX_CHARSET_NAME_LENGTH 2
1987
1988 PERL_STATIC_INLINE const char *
1989 S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1990 {
1991     PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
1992
1993     /* Returns a string that corresponds to the name of the regex character set
1994      * given by 'flags', and *lenp is set the length of that string, which
1995      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1996
1997     *lenp = 1;
1998     switch (get_regex_charset(flags)) {
1999         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
2000         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
2001         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
2002         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
2003         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
2004             *lenp = 2;
2005             return ASCII_MORE_RESTRICT_PAT_MODS;
2006     }
2007     /* The NOT_REACHED; hides an assert() which has a rather complex
2008      * definition in perl.h. */
2009     NOT_REACHED; /* NOTREACHED */
2010     return "?";     /* Unknown */
2011 }
2012
2013 #endif
2014
2015 /*
2016
2017 Return false if any get magic is on the SV other than taint magic.
2018
2019 */
2020
2021 PERL_STATIC_INLINE bool
2022 Perl_sv_only_taint_gmagic(SV *sv)
2023 {
2024     MAGIC *mg = SvMAGIC(sv);
2025
2026     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2027
2028     while (mg) {
2029         if (mg->mg_type != PERL_MAGIC_taint
2030             && !(mg->mg_flags & MGf_GSKIP)
2031             && mg->mg_virtual->svt_get) {
2032             return FALSE;
2033         }
2034         mg = mg->mg_moremagic;
2035     }
2036
2037     return TRUE;
2038 }
2039
2040 /* ------------------ cop.h ------------------------------------------- */
2041
2042 /* implement GIMME_V() macro */
2043
2044 PERL_STATIC_INLINE U8
2045 Perl_gimme_V(pTHX)
2046 {
2047     I32 cxix;
2048     U8  gimme = (PL_op->op_flags & OPf_WANT);
2049
2050     if (gimme)
2051         return gimme;
2052     cxix = PL_curstackinfo->si_cxsubix;
2053     if (cxix < 0)
2054         return G_VOID;
2055     assert(cxstack[cxix].blk_gimme & G_WANT);
2056     return (cxstack[cxix].blk_gimme & G_WANT);
2057 }
2058
2059
2060 /* Enter a block. Push a new base context and return its address. */
2061
2062 PERL_STATIC_INLINE PERL_CONTEXT *
2063 Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
2064 {
2065     PERL_CONTEXT * cx;
2066
2067     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2068
2069     CXINC;
2070     cx = CX_CUR();
2071     cx->cx_type        = type;
2072     cx->blk_gimme      = gimme;
2073     cx->blk_oldsaveix  = saveix;
2074     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
2075     cx->blk_oldcop     = PL_curcop;
2076     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
2077     cx->blk_oldscopesp = PL_scopestack_ix;
2078     cx->blk_oldpm      = PL_curpm;
2079     cx->blk_old_tmpsfloor = PL_tmps_floor;
2080
2081     PL_tmps_floor        = PL_tmps_ix;
2082     CX_DEBUG(cx, "PUSH");
2083     return cx;
2084 }
2085
2086
2087 /* Exit a block (RETURN and LAST). */
2088
2089 PERL_STATIC_INLINE void
2090 Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
2091 {
2092     PERL_ARGS_ASSERT_CX_POPBLOCK;
2093
2094     CX_DEBUG(cx, "POP");
2095     /* these 3 are common to cx_popblock and cx_topblock */
2096     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2097     PL_scopestack_ix = cx->blk_oldscopesp;
2098     PL_curpm         = cx->blk_oldpm;
2099
2100     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2101      * and leaves a CX entry lying around for repeated use, so
2102      * skip for multicall */                  \
2103     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2104             || PL_savestack_ix == cx->blk_oldsaveix);
2105     PL_curcop     = cx->blk_oldcop;
2106     PL_tmps_floor = cx->blk_old_tmpsfloor;
2107 }
2108
2109 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2110  * Whereas cx_popblock() restores the state to the point just before
2111  * cx_pushblock() was called,  cx_topblock() restores it to the point just
2112  * *after* cx_pushblock() was called. */
2113
2114 PERL_STATIC_INLINE void
2115 Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
2116 {
2117     PERL_ARGS_ASSERT_CX_TOPBLOCK;
2118
2119     CX_DEBUG(cx, "TOP");
2120     /* these 3 are common to cx_popblock and cx_topblock */
2121     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2122     PL_scopestack_ix = cx->blk_oldscopesp;
2123     PL_curpm         = cx->blk_oldpm;
2124
2125     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
2126 }
2127
2128
2129 PERL_STATIC_INLINE void
2130 Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
2131 {
2132     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2133
2134     PERL_ARGS_ASSERT_CX_PUSHSUB;
2135
2136     PERL_DTRACE_PROBE_ENTRY(cv);
2137     cx->blk_sub.old_cxsubix     = PL_curstackinfo->si_cxsubix;
2138     PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
2139     cx->blk_sub.cv = cv;
2140     cx->blk_sub.olddepth = CvDEPTH(cv);
2141     cx->blk_sub.prevcomppad = PL_comppad;
2142     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2143     cx->blk_sub.retop = retop;
2144     SvREFCNT_inc_simple_void_NN(cv);
2145     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2146 }
2147
2148
2149 /* subsets of cx_popsub() */
2150
2151 PERL_STATIC_INLINE void
2152 Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
2153 {
2154     CV *cv;
2155
2156     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2157     assert(CxTYPE(cx) == CXt_SUB);
2158
2159     PL_comppad = cx->blk_sub.prevcomppad;
2160     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2161     cv = cx->blk_sub.cv;
2162     CvDEPTH(cv) = cx->blk_sub.olddepth;
2163     cx->blk_sub.cv = NULL;
2164     SvREFCNT_dec(cv);
2165     PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
2166 }
2167
2168
2169 /* handle the @_ part of leaving a sub */
2170
2171 PERL_STATIC_INLINE void
2172 Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
2173 {
2174     AV *av;
2175
2176     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2177     assert(CxTYPE(cx) == CXt_SUB);
2178     assert(AvARRAY(MUTABLE_AV(
2179         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2180                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2181
2182     CX_POP_SAVEARRAY(cx);
2183     av = MUTABLE_AV(PAD_SVl(0));
2184     if (UNLIKELY(AvREAL(av)))
2185         /* abandon @_ if it got reified */
2186         clear_defarray(av, 0);
2187     else {
2188         CLEAR_ARGARRAY(av);
2189     }
2190 }
2191
2192
2193 PERL_STATIC_INLINE void
2194 Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
2195 {
2196     PERL_ARGS_ASSERT_CX_POPSUB;
2197     assert(CxTYPE(cx) == CXt_SUB);
2198
2199     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
2200
2201     if (CxHASARGS(cx))
2202         cx_popsub_args(cx);
2203     cx_popsub_common(cx);
2204 }
2205
2206
2207 PERL_STATIC_INLINE void
2208 Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
2209 {
2210     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2211
2212     cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
2213     PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2214     cx->blk_format.cv          = cv;
2215     cx->blk_format.retop       = retop;
2216     cx->blk_format.gv          = gv;
2217     cx->blk_format.dfoutgv     = PL_defoutgv;
2218     cx->blk_format.prevcomppad = PL_comppad;
2219     cx->blk_u16                = 0;
2220
2221     SvREFCNT_inc_simple_void_NN(cv);
2222     CvDEPTH(cv)++;
2223     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2224 }
2225
2226
2227 PERL_STATIC_INLINE void
2228 Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
2229 {
2230     CV *cv;
2231     GV *dfout;
2232
2233     PERL_ARGS_ASSERT_CX_POPFORMAT;
2234     assert(CxTYPE(cx) == CXt_FORMAT);
2235
2236     dfout = cx->blk_format.dfoutgv;
2237     setdefout(dfout);
2238     cx->blk_format.dfoutgv = NULL;
2239     SvREFCNT_dec_NN(dfout);
2240
2241     PL_comppad = cx->blk_format.prevcomppad;
2242     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2243     cv = cx->blk_format.cv;
2244     cx->blk_format.cv = NULL;
2245     --CvDEPTH(cv);
2246     SvREFCNT_dec_NN(cv);
2247     PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
2248 }
2249
2250
2251 PERL_STATIC_INLINE void
2252 Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
2253 {
2254     PERL_ARGS_ASSERT_CX_PUSHEVAL;
2255
2256     cx->blk_eval.old_cxsubix   = PL_curstackinfo->si_cxsubix;
2257     PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
2258     cx->blk_eval.retop         = retop;
2259     cx->blk_eval.old_namesv    = namesv;
2260     cx->blk_eval.old_eval_root = PL_eval_root;
2261     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
2262     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
2263     cx->blk_eval.cur_top_env   = PL_top_env;
2264
2265     assert(!(PL_in_eval     & ~ 0x3F));
2266     assert(!(PL_op->op_type & ~0x1FF));
2267     cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
2268 }
2269
2270
2271 PERL_STATIC_INLINE void
2272 Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
2273 {
2274     SV *sv;
2275
2276     PERL_ARGS_ASSERT_CX_POPEVAL;
2277     assert(CxTYPE(cx) == CXt_EVAL);
2278
2279     PL_in_eval = CxOLD_IN_EVAL(cx);
2280     assert(!(PL_in_eval & 0xc0));
2281     PL_eval_root = cx->blk_eval.old_eval_root;
2282     sv = cx->blk_eval.cur_text;
2283     if (sv && CxEVAL_TXT_REFCNTED(cx)) {
2284         cx->blk_eval.cur_text = NULL;
2285         SvREFCNT_dec_NN(sv);
2286     }
2287
2288     sv = cx->blk_eval.old_namesv;
2289     if (sv) {
2290         cx->blk_eval.old_namesv = NULL;
2291         SvREFCNT_dec_NN(sv);
2292     }
2293     PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
2294 }
2295
2296
2297 /* push a plain loop, i.e.
2298  *     { block }
2299  *     while (cond) { block }
2300  *     for (init;cond;continue) { block }
2301  * This loop can be last/redo'ed etc.
2302  */
2303
2304 PERL_STATIC_INLINE void
2305 Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
2306 {
2307     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2308     cx->blk_loop.my_op = cLOOP;
2309 }
2310
2311
2312 /* push a true for loop, i.e.
2313  *     for var (list) { block }
2314  */
2315
2316 PERL_STATIC_INLINE void
2317 Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
2318 {
2319     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2320
2321     /* this one line is common with cx_pushloop_plain */
2322     cx->blk_loop.my_op = cLOOP;
2323
2324     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2325     cx->blk_loop.itersave      = itersave;
2326 #ifdef USE_ITHREADS
2327     cx->blk_loop.oldcomppad = PL_comppad;
2328 #endif
2329 }
2330
2331
2332 /* pop all loop types, including plain */
2333
2334 PERL_STATIC_INLINE void
2335 Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
2336 {
2337     PERL_ARGS_ASSERT_CX_POPLOOP;
2338
2339     assert(CxTYPE_is_LOOP(cx));
2340     if (  CxTYPE(cx) == CXt_LOOP_ARY
2341        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2342     {
2343         /* Free ary or cur. This assumes that state_u.ary.ary
2344          * aligns with state_u.lazysv.cur. See cx_dup() */
2345         SV *sv = cx->blk_loop.state_u.lazysv.cur;
2346         cx->blk_loop.state_u.lazysv.cur = NULL;
2347         SvREFCNT_dec_NN(sv);
2348         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2349             sv = cx->blk_loop.state_u.lazysv.end;
2350             cx->blk_loop.state_u.lazysv.end = NULL;
2351             SvREFCNT_dec_NN(sv);
2352         }
2353     }
2354     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2355         SV *cursv;
2356         SV **svp = (cx)->blk_loop.itervar_u.svp;
2357         if ((cx->cx_type & CXp_FOR_GV))
2358             svp = &GvSV((GV*)svp);
2359         cursv = *svp;
2360         *svp = cx->blk_loop.itersave;
2361         cx->blk_loop.itersave = NULL;
2362         SvREFCNT_dec(cursv);
2363     }
2364 }
2365
2366
2367 PERL_STATIC_INLINE void
2368 Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2369 {
2370     PERL_ARGS_ASSERT_CX_PUSHWHEN;
2371
2372     cx->blk_givwhen.leave_op = cLOGOP->op_other;
2373 }
2374
2375
2376 PERL_STATIC_INLINE void
2377 Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2378 {
2379     PERL_ARGS_ASSERT_CX_POPWHEN;
2380     assert(CxTYPE(cx) == CXt_WHEN);
2381
2382     PERL_UNUSED_ARG(cx);
2383     PERL_UNUSED_CONTEXT;
2384     /* currently NOOP */
2385 }
2386
2387
2388 PERL_STATIC_INLINE void
2389 Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
2390 {
2391     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2392
2393     cx->blk_givwhen.leave_op = cLOGOP->op_other;
2394     cx->blk_givwhen.defsv_save = orig_defsv;
2395 }
2396
2397
2398 PERL_STATIC_INLINE void
2399 Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2400 {
2401     SV *sv;
2402
2403     PERL_ARGS_ASSERT_CX_POPGIVEN;
2404     assert(CxTYPE(cx) == CXt_GIVEN);
2405
2406     sv = GvSV(PL_defgv);
2407     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2408     cx->blk_givwhen.defsv_save = NULL;
2409     SvREFCNT_dec(sv);
2410 }
2411
2412 /* ------------------ util.h ------------------------------------------- */
2413
2414 /*
2415 =head1 Miscellaneous Functions
2416
2417 =for apidoc foldEQ
2418
2419 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2420 same
2421 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
2422 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
2423 range bytes match only themselves.
2424
2425 =cut
2426 */
2427
2428 PERL_STATIC_INLINE I32
2429 Perl_foldEQ(const char *s1, const char *s2, I32 len)
2430 {
2431     const U8 *a = (const U8 *)s1;
2432     const U8 *b = (const U8 *)s2;
2433
2434     PERL_ARGS_ASSERT_FOLDEQ;
2435
2436     assert(len >= 0);
2437
2438     while (len--) {
2439         if (*a != *b && *a != PL_fold[*b])
2440             return 0;
2441         a++,b++;
2442     }
2443     return 1;
2444 }
2445
2446 PERL_STATIC_INLINE I32
2447 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2448 {
2449     /* Compare non-UTF-8 using Unicode (Latin1) semantics.  Works on all folds
2450      * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2451      * does not check for this.  Nor does it check that the strings each have
2452      * at least 'len' characters. */
2453
2454     const U8 *a = (const U8 *)s1;
2455     const U8 *b = (const U8 *)s2;
2456
2457     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2458
2459     assert(len >= 0);
2460
2461     while (len--) {
2462         if (*a != *b && *a != PL_fold_latin1[*b]) {
2463             return 0;
2464         }
2465         a++, b++;
2466     }
2467     return 1;
2468 }
2469
2470 /*
2471 =for apidoc foldEQ_locale
2472
2473 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2474 same case-insensitively in the current locale; false otherwise.
2475
2476 =cut
2477 */
2478
2479 PERL_STATIC_INLINE I32
2480 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2481 {
2482     dVAR;
2483     const U8 *a = (const U8 *)s1;
2484     const U8 *b = (const U8 *)s2;
2485
2486     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2487
2488     assert(len >= 0);
2489
2490     while (len--) {
2491         if (*a != *b && *a != PL_fold_locale[*b])
2492             return 0;
2493         a++,b++;
2494     }
2495     return 1;
2496 }
2497
2498 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2499
2500 PERL_STATIC_INLINE void *
2501 S_my_memrchr(const char * s, const char c, const STRLEN len)
2502 {
2503     /* memrchr(), since many platforms lack it */
2504
2505     const char * t = s + len - 1;
2506
2507     PERL_ARGS_ASSERT_MY_MEMRCHR;
2508
2509     while (t >= s) {
2510         if (*t == c) {
2511             return (void *) t;
2512         }
2513         t--;
2514     }
2515
2516     return NULL;
2517 }
2518
2519 #endif
2520
2521 /*
2522  * ex: set ts=8 sts=4 sw=4 et:
2523  */