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 is a home for static inline functions that cannot go in other
   9  * headers files, because they depend on proto.h (included after most other
  10  * headers) or struct definitions.
  11  *
  12  * Each section names the header file that the functions "belong" to.
  13  */
  14
  15 /* ------------------------------- av.h ------------------------------- */
  16
  17 PERL_STATIC_INLINE SSize_t
  18 S_av_top_index(pTHX_ AV *av)
  19 {
  20     PERL_ARGS_ASSERT_AV_TOP_INDEX;
  21     assert(SvTYPE(av) == SVt_PVAV);
  22
  23     return AvFILL(av);
  24 }
  25
  26 /* ------------------------------- cv.h ------------------------------- */
  27
  28 PERL_STATIC_INLINE GV *
  29 S_CvGV(pTHX_ CV *sv)
  30 {
  31     return CvNAMED(sv)
  32         ? Perl_cvgv_from_hek(aTHX_ sv)
  33         : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
  34 }
  35
  36 PERL_STATIC_INLINE I32 *
  37 S_CvDEPTHp(const CV * const sv)
  38 {
  39     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
  40     return &((XPVCV*)SvANY(sv))->xcv_depth;
  41 }
  42
  43 /*
  44  CvPROTO returns the prototype as stored, which is not necessarily what
  45  the interpreter should be using. Specifically, the interpreter assumes
  46  that spaces have been stripped, which has been the case if the prototype
  47  was added by toke.c, but is generally not the case if it was added elsewhere.
  48  Since we can't enforce the spacelessness at assignment time, this routine
  49  provides a temporary copy at parse time with spaces removed.
  50  I<orig> is the start of the original buffer, I<len> is the length of the
  51  prototype and will be updated when this returns.
  52  */
  53
  54 #ifdef PERL_CORE
  55 PERL_STATIC_INLINE char *
  56 S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
  57 {
  58     SV * tmpsv;
  59     char * tmps;
  60     tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
  61     tmps = SvPVX(tmpsv);
  62     while ((*len)--) {
  63         if (!isSPACE(*orig))
  64             *tmps++ = *orig;
  65         orig++;
  66     }
  67     *tmps = '\0';
  68     *len = tmps - SvPVX(tmpsv);
  69                 return SvPVX(tmpsv);
  70 }
  71 #endif
  72
  73 /* ------------------------------- mg.h ------------------------------- */
  74
  75 #if defined(PERL_CORE) || defined(PERL_EXT)
  76 /* assumes get-magic and stringification have already occurred */
  77 PERL_STATIC_INLINE STRLEN
  78 S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
  79 {
  80     assert(mg->mg_type == PERL_MAGIC_regex_global);
  81     assert(mg->mg_len != -1);
  82     if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
  83         return (STRLEN)mg->mg_len;
  84     else {
  85         const STRLEN pos = (STRLEN)mg->mg_len;
  86         /* Without this check, we may read past the end of the buffer: */
  87         if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
  88         return sv_or_pv_pos_u2b(sv, s, pos, NULL);
  89     }
  90 }
  91 #endif
  92
  93 /* ------------------------------- pad.h ------------------------------ */
  94
  95 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
  96 PERL_STATIC_INLINE bool
  97 PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
  98 {
  99     /* is seq within the range _LOW to _HIGH ?
 100      * This is complicated by the fact that PL_cop_seqmax
 101      * may have wrapped around at some point */
 102     if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
 103         return FALSE; /* not yet introduced */
 104
 105     if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
 106     /* in compiling scope */
 107         if (
 108             (seq >  COP_SEQ_RANGE_LOW(pn))
 109             ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
 110             : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
 111         )
 112             return TRUE;
 113     }
 114     else if (
 115         (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
 116         ?
 117             (  seq >  COP_SEQ_RANGE_LOW(pn)
 118             || seq <= COP_SEQ_RANGE_HIGH(pn))
 119
 120         :    (  seq >  COP_SEQ_RANGE_LOW(pn)
 121              && seq <= COP_SEQ_RANGE_HIGH(pn))
 122     )
 123         return TRUE;
 124     return FALSE;
 125 }
 126 #endif
 127
 128 /* ------------------------------- pp.h ------------------------------- */
 129
 130 PERL_STATIC_INLINE I32
 131 S_TOPMARK(pTHX)
 132 {
 133     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
 134                                  "MARK top  %p %" IVdf "\n",
 135                                   PL_markstack_ptr,
 136                                   (IV)*PL_markstack_ptr)));
 137     return *PL_markstack_ptr;
 138 }
 139
 140 PERL_STATIC_INLINE I32
 141 S_POPMARK(pTHX)
 142 {
 143     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
 144                                  "MARK pop  %p %" IVdf "\n",
 145                                   (PL_markstack_ptr-1),
 146                                   (IV)*(PL_markstack_ptr-1))));
 147     assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
 148     return *PL_markstack_ptr--;
 149 }
 150
 151 /* ----------------------------- regexp.h ----------------------------- */
 152
 153 PERL_STATIC_INLINE struct regexp *
 154 S_ReANY(const REGEXP * const re)
 155 {
 156     XPV* const p = (XPV*)SvANY(re);
 157     assert(isREGEXP(re));
 158     return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
 159                                    : (struct regexp *)p;
 160 }
 161
 162 /* ------------------------------- sv.h ------------------------------- */
 163
 164 PERL_STATIC_INLINE SV *
 165 S_SvREFCNT_inc(SV *sv)
 166 {
 167     if (LIKELY(sv != NULL))
 168         SvREFCNT(sv)++;
 169     return sv;
 170 }
 171 PERL_STATIC_INLINE SV *
 172 S_SvREFCNT_inc_NN(SV *sv)
 173 {
 174     SvREFCNT(sv)++;
 175     return sv;
 176 }
 177 PERL_STATIC_INLINE void
 178 S_SvREFCNT_inc_void(SV *sv)
 179 {
 180     if (LIKELY(sv != NULL))
 181         SvREFCNT(sv)++;
 182 }
 183 PERL_STATIC_INLINE void
 184 S_SvREFCNT_dec(pTHX_ SV *sv)
 185 {
 186     if (LIKELY(sv != NULL)) {
 187         U32 rc = SvREFCNT(sv);
 188         if (LIKELY(rc > 1))
 189             SvREFCNT(sv) = rc - 1;
 190         else
 191             Perl_sv_free2(aTHX_ sv, rc);
 192     }
 193 }
 194
 195 PERL_STATIC_INLINE void
 196 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
 197 {
 198     U32 rc = SvREFCNT(sv);
 199     if (LIKELY(rc > 1))
 200         SvREFCNT(sv) = rc - 1;
 201     else
 202         Perl_sv_free2(aTHX_ sv, rc);
 203 }
 204
 205 PERL_STATIC_INLINE void
 206 SvAMAGIC_on(SV *sv)
 207 {
 208     assert(SvROK(sv));
 209     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
 210 }
 211 PERL_STATIC_INLINE void
 212 SvAMAGIC_off(SV *sv)
 213 {
 214     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
 215         HvAMAGIC_off(SvSTASH(SvRV(sv)));
 216 }
 217
 218 PERL_STATIC_INLINE U32
 219 S_SvPADSTALE_on(SV *sv)
 220 {
 221     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 222     return SvFLAGS(sv) |= SVs_PADSTALE;
 223 }
 224 PERL_STATIC_INLINE U32
 225 S_SvPADSTALE_off(SV *sv)
 226 {
 227     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 228     return SvFLAGS(sv) &= ~SVs_PADSTALE;
 229 }
 230 #if defined(PERL_CORE) || defined (PERL_EXT)
 231 PERL_STATIC_INLINE STRLEN
 232 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 233 {
 234     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
 235     if (SvGAMAGIC(sv)) {
 236         U8 *hopped = utf8_hop((U8 *)pv, pos);
 237         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
 238         return (STRLEN)(hopped - (U8 *)pv);
 239     }
 240     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
 241 }
 242 #endif
 243
 244 /* ------------------------------- handy.h ------------------------------- */
 245
 246 /* saves machine code for a common noreturn idiom typically used in Newx*() */
 247 #ifdef GCC_DIAG_PRAGMA
 248 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
 249 #endif
 250 static void
 251 S_croak_memory_wrap(void)
 252 {
 253     Perl_croak_nocontext("%s",PL_memory_wrap);
 254 }
 255 #ifdef GCC_DIAG_PRAGMA
 256 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
 257 #endif
 258
 259 /* ------------------------------- utf8.h ------------------------------- */
 260
 261 /*
 262 =head1 Unicode Support
 263 */
 264
 265 PERL_STATIC_INLINE void
 266 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
 267 {
 268     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
 269      * encoded string at '*dest', updating '*dest' to include it */
 270
 271     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
 272
 273     if (NATIVE_BYTE_IS_INVARIANT(byte))
 274         *((*dest)++) = byte;
 275     else {
 276         *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
 277         *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
 278     }
 279 }
 280
 281 /*
 282 =for apidoc valid_utf8_to_uvchr
 283 Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
 284 the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
 285 it passes C<L</isUTF8_CHAR>>.  Surrogates, non-character code points, and
 286 non-Unicode code points are allowed.
 287
 288 =cut
 289
 290  */
 291
 292 PERL_STATIC_INLINE UV
 293 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
 294 {
 295     const UV expectlen = UTF8SKIP(s);
 296     const U8* send = s + expectlen;
 297     UV uv = *s;
 298
 299     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
 300
 301     if (retlen) {
 302         *retlen = expectlen;
 303     }
 304
 305     /* An invariant is trivially returned */
 306     if (expectlen == 1) {
 307         return uv;
 308     }
 309
 310     /* Remove the leading bits that indicate the number of bytes, leaving just
 311      * the bits that are part of the value */
 312     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
 313
 314     /* Now, loop through the remaining bytes, accumulating each into the
 315      * working total as we go.  (I khw tried unrolling the loop for up to 4
 316      * bytes, but there was no performance improvement) */
 317     for (++s; s < send; s++) {
 318         uv = UTF8_ACCUMULATE(uv, *s);
 319     }
 320
 321     return UNI_TO_NATIVE(uv);
 322
 323 }
 324
 325 /*
 326 =for apidoc is_utf8_invariant_string
 327
 328 Returns TRUE if the first C<len> bytes of the string C<s> are the same
 329 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
 330 EBCDIC machines); otherwise it returns FALSE.  That is, it returns TRUE if they
 331 are UTF-8 invariant.  On ASCII-ish machines, all the ASCII characters and only
 332 the ASCII characters fit this definition.  On EBCDIC machines, the ASCII-range
 333 characters are invariant, but so also are the C1 controls.
 334
 335 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
 336 use this option, that C<s> can't have embedded C<NUL> characters and has to
 337 have a terminating C<NUL> byte).
 338
 339 See also
 340 C<L</is_utf8_string>>,
 341 C<L</is_utf8_string_flags>>,
 342 C<L</is_utf8_string_loc>>,
 343 C<L</is_utf8_string_loc_flags>>,
 344 C<L</is_utf8_string_loclen>>,
 345 C<L</is_utf8_string_loclen_flags>>,
 346 C<L</is_utf8_fixed_width_buf_flags>>,
 347 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 348 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 349 C<L</is_strict_utf8_string>>,
 350 C<L</is_strict_utf8_string_loc>>,
 351 C<L</is_strict_utf8_string_loclen>>,
 352 C<L</is_c9strict_utf8_string>>,
 353 C<L</is_c9strict_utf8_string_loc>>,
 354 and
 355 C<L</is_c9strict_utf8_string_loclen>>.
 356
 357 =cut
 358
 359 */
 360
 361 #define is_utf8_invariant_string(s, len)                                    \
 362                                 is_utf8_invariant_string_loc(s, len, NULL)
 363
 364 /*
 365 =for apidoc is_utf8_invariant_string_loc
 366
 367 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
 368 the first UTF-8 variant character in the C<ep> pointer; if all characters are
 369 UTF-8 invariant, this function does not change the contents of C<*ep>.
 370
 371 =cut
 372
 373 */
 374
 375 PERL_STATIC_INLINE bool
 376 S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
 377 {
 378     const U8* send;
 379     const U8* x = s;
 380
 381     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
 382
 383     if (len == 0) {
 384         len = strlen((const char *)s);
 385     }
 386
 387     send = s + len;
 388
 389 #ifndef EBCDIC
 390
 391 /* This looks like 0x010101... */
 392 #define PERL_COUNT_MULTIPLIER   (~ (UINTMAX_C(0)) / 0xFF)
 393
 394 /* This looks like 0x808080... */
 395 #define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
 396 #define PERL_WORDSIZE            sizeof(PERL_COUNT_MULTIPLIER)
 397 #define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
 398
 399 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
 400  * or'ing together the lowest bits of 'x'.  Hopefully the final term gets
 401  * optimized out completely on a 32-bit system, and its mask gets optimized out
 402  * on a 64-bit system */
 403 #define PERL_IS_SUBWORD_ADDR(x) (1 & (     PTR2nat(x)                      \
 404                                       |   (PTR2nat(x) >> 1)                \
 405                                       | ( (PTR2nat(x) >> 2)                \
 406                                          & PERL_WORD_BOUNDARY_MASK)))
 407
 408     /* Do the word-at-a-time iff there is at least one usable full word.  That
 409      * means that after advancing to a word boundary, there still is at least a
 410      * full word left.  The number of bytes needed to advance is 'wordsize -
 411      * offset' unless offset is 0. */
 412     if ((STRLEN) (send - x) >= PERL_WORDSIZE
 413
 414                             /* This term is wordsize if subword; 0 if not */
 415                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
 416
 417                             /* 'offset' */
 418                           - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
 419     {
 420
 421         /* Process per-byte until reach word boundary.  XXX This loop could be
 422          * eliminated if we knew that this platform had fast unaligned reads */
 423         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
 424             if (! UTF8_IS_INVARIANT(*x)) {
 425                 if (ep) {
 426                     *ep = x;
 427                 }
 428
 429                 return FALSE;
 430             }
 431             x++;
 432         }
 433
 434         /* Here, we know we have at least one full word to process.  Process
 435          * per-word as long as we have at least a full word left */
 436         do {
 437             if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK)  {
 438
 439                 /* Found a variant.  Just return if caller doesn't want its
 440                  * exact position */
 441                 if (! ep) {
 442                     return FALSE;
 443                 }
 444
 445                 /* Otherwise fall into final loop to find which byte it is */
 446                 break;
 447             }
 448             x += PERL_WORDSIZE;
 449         } while (x + PERL_WORDSIZE <= send);
 450     }
 451
 452 #  undef PERL_WORDSIZE
 453 #  undef PERL_WORD_BOUNDARY_MASK
 454 #  undef PERL_VARIANTS_WORD_MASK
 455 #endif
 456
 457     /* Process per-byte */
 458     while (x < send) {
 459         if (! UTF8_IS_INVARIANT(*x)) {
 460             if (ep) {
 461                 *ep = x;
 462             }
 463
 464             return FALSE;
 465         }
 466
 467         x++;
 468     }
 469
 470     return TRUE;
 471 }
 472
 473 /*
 474 =for apidoc is_utf8_string
 475
 476 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 477 Perl-extended-UTF-8 string; returns FALSE otherwise.  If C<len> is 0, it will
 478 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
 479 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
 480 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
 481
 482 This function considers Perl's extended UTF-8 to be valid.  That means that
 483 code points above Unicode, surrogates, and non-character code points are
 484 considered valid by this function.  Use C<L</is_strict_utf8_string>>,
 485 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
 486 code points are considered valid.
 487
 488 See also
 489 C<L</is_utf8_invariant_string>>,
 490 C<L</is_utf8_invariant_string_loc>>,
 491 C<L</is_utf8_string_loc>>,
 492 C<L</is_utf8_string_loclen>>,
 493 C<L</is_utf8_fixed_width_buf_flags>>,
 494 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 495 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 496
 497 =cut
 498 */
 499
 500 #define is_utf8_string(s, len)  is_utf8_string_loclen(s, len, NULL, NULL)
 501
 502 #if defined(PERL_CORE) || defined (PERL_EXT)
 503
 504 /*
 505 =for apidoc is_utf8_non_invariant_string
 506
 507 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
 508 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
 509 UTF-8; otherwise returns FALSE.
 510
 511 A TRUE return means that at least one code point represented by the sequence
 512 either is a wide character not representable as a single byte, or the
 513 representation differs depending on whether the sequence is encoded in UTF-8 or
 514 not.
 515
 516 See also
 517 C<L<perlapi/is_utf8_invariant_string>>,
 518 C<L<perlapi/is_utf8_string>>
 519
 520 =cut
 521
 522 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
 523 It needn't be if its string is entirely UTF-8 invariant, and it shouldn't be if
 524 it otherwise contains invalid UTF-8.
 525
 526 It is an internal function because khw thinks that XS code shouldn't be working
 527 at this low a level.  A valid use case could change that.
 528
 529 */
 530
 531 PERL_STATIC_INLINE bool
 532 S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
 533 {
 534     const U8 * first_variant;
 535
 536     PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
 537
 538     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 539         return FALSE;
 540     }
 541
 542     return is_utf8_string(first_variant, len - (first_variant - s));
 543 }
 544
 545 #endif
 546
 547 /*
 548 =for apidoc is_strict_utf8_string
 549
 550 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 551 UTF-8-encoded string that is fully interchangeable by any application using
 552 Unicode rules; otherwise it returns FALSE.  If C<len> is 0, it will be
 553 calculated using C<strlen(s)> (which means if you use this option, that C<s>
 554 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
 555 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
 556
 557 This function returns FALSE for strings containing any
 558 code points above the Unicode max of 0x10FFFF, surrogate code points, or
 559 non-character code points.
 560
 561 See also
 562 C<L</is_utf8_invariant_string>>,
 563 C<L</is_utf8_invariant_string_loc>>,
 564 C<L</is_utf8_string>>,
 565 C<L</is_utf8_string_flags>>,
 566 C<L</is_utf8_string_loc>>,
 567 C<L</is_utf8_string_loc_flags>>,
 568 C<L</is_utf8_string_loclen>>,
 569 C<L</is_utf8_string_loclen_flags>>,
 570 C<L</is_utf8_fixed_width_buf_flags>>,
 571 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 572 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 573 C<L</is_strict_utf8_string_loc>>,
 574 C<L</is_strict_utf8_string_loclen>>,
 575 C<L</is_c9strict_utf8_string>>,
 576 C<L</is_c9strict_utf8_string_loc>>,
 577 and
 578 C<L</is_c9strict_utf8_string_loclen>>.
 579
 580 =cut
 581 */
 582
 583 #define is_strict_utf8_string(s, len)  is_strict_utf8_string_loclen(s, len, NULL, NULL)
 584
 585 /*
 586 =for apidoc is_c9strict_utf8_string
 587
 588 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 589 UTF-8-encoded string that conforms to
 590 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
 591 otherwise it returns FALSE.  If C<len> is 0, it will be calculated using
 592 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
 593 C<NUL> characters and has to have a terminating C<NUL> byte).  Note that all
 594 characters being ASCII constitute 'a valid UTF-8 string'.
 595
 596 This function returns FALSE for strings containing any code points above the
 597 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
 598 code points per
 599 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
 600
 601 See also
 602 C<L</is_utf8_invariant_string>>,
 603 C<L</is_utf8_invariant_string_loc>>,
 604 C<L</is_utf8_string>>,
 605 C<L</is_utf8_string_flags>>,
 606 C<L</is_utf8_string_loc>>,
 607 C<L</is_utf8_string_loc_flags>>,
 608 C<L</is_utf8_string_loclen>>,
 609 C<L</is_utf8_string_loclen_flags>>,
 610 C<L</is_utf8_fixed_width_buf_flags>>,
 611 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 612 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 613 C<L</is_strict_utf8_string>>,
 614 C<L</is_strict_utf8_string_loc>>,
 615 C<L</is_strict_utf8_string_loclen>>,
 616 C<L</is_c9strict_utf8_string_loc>>,
 617 and
 618 C<L</is_c9strict_utf8_string_loclen>>.
 619
 620 =cut
 621 */
 622
 623 #define is_c9strict_utf8_string(s, len)  is_c9strict_utf8_string_loclen(s, len, NULL, 0)
 624
 625 /*
 626 =for apidoc is_utf8_string_flags
 627
 628 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 629 UTF-8 string, subject to the restrictions imposed by C<flags>;
 630 returns FALSE otherwise.  If C<len> is 0, it will be calculated
 631 using C<strlen(s)> (which means if you use this option, that C<s> can't have
 632 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
 633 that all characters being ASCII constitute 'a valid UTF-8 string'.
 634
 635 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
 636 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
 637 as C<L</is_strict_utf8_string>>; and if C<flags> is
 638 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
 639 C<L</is_c9strict_utf8_string>>.  Otherwise C<flags> may be any
 640 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
 641 C<L</utf8n_to_uvchr>>, with the same meanings.
 642
 643 See also
 644 C<L</is_utf8_invariant_string>>,
 645 C<L</is_utf8_invariant_string_loc>>,
 646 C<L</is_utf8_string>>,
 647 C<L</is_utf8_string_loc>>,
 648 C<L</is_utf8_string_loc_flags>>,
 649 C<L</is_utf8_string_loclen>>,
 650 C<L</is_utf8_string_loclen_flags>>,
 651 C<L</is_utf8_fixed_width_buf_flags>>,
 652 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 653 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 654 C<L</is_strict_utf8_string>>,
 655 C<L</is_strict_utf8_string_loc>>,
 656 C<L</is_strict_utf8_string_loclen>>,
 657 C<L</is_c9strict_utf8_string>>,
 658 C<L</is_c9strict_utf8_string_loc>>,
 659 and
 660 C<L</is_c9strict_utf8_string_loclen>>.
 661
 662 =cut
 663 */
 664
 665 PERL_STATIC_INLINE bool
 666 S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
 667 {
 668     const U8 * first_variant;
 669
 670     PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
 671     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
 672                           |UTF8_DISALLOW_PERL_EXTENDED)));
 673
 674     if (len == 0) {
 675         len = strlen((const char *)s);
 676     }
 677
 678     if (flags == 0) {
 679         return is_utf8_string(s, len);
 680     }
 681
 682     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 683                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
 684     {
 685         return is_strict_utf8_string(s, len);
 686     }
 687
 688     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 689                                        == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
 690     {
 691         return is_c9strict_utf8_string(s, len);
 692     }
 693
 694     if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
 695         const U8* const send = s + len;
 696         const U8* x = first_variant;
 697
 698         while (x < send) {
 699             STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
 700             if (UNLIKELY(! cur_len)) {
 701                 return FALSE;
 702             }
 703             x += cur_len;
 704         }
 705     }
 706
 707     return TRUE;
 708 }
 709
 710 /*
 711
 712 =for apidoc is_utf8_string_loc
 713
 714 Like C<L</is_utf8_string>> but stores the location of the failure (in the
 715 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 716 "utf8ness success") in the C<ep> pointer.
 717
 718 See also C<L</is_utf8_string_loclen>>.
 719
 720 =cut
 721 */
 722
 723 #define is_utf8_string_loc(s, len, ep)  is_utf8_string_loclen(s, len, ep, 0)
 724
 725 /*
 726
 727 =for apidoc is_utf8_string_loclen
 728
 729 Like C<L</is_utf8_string>> but stores the location of the failure (in the
 730 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 731 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
 732 encoded characters in the C<el> pointer.
 733
 734 See also C<L</is_utf8_string_loc>>.
 735
 736 =cut
 737 */
 738
 739 PERL_STATIC_INLINE bool
 740 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 741 {
 742     const U8 * first_variant;
 743
 744     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 745
 746     if (len == 0) {
 747         len = strlen((const char *) s);
 748     }
 749
 750     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 751         if (el)
 752             *el = len;
 753
 754         if (ep) {
 755             *ep = s + len;
 756         }
 757
 758         return TRUE;
 759     }
 760
 761     {
 762         const U8* const send = s + len;
 763         const U8* x = first_variant;
 764         STRLEN outlen = first_variant - s;
 765
 766         while (x < send) {
 767             const STRLEN cur_len = isUTF8_CHAR(x, send);
 768             if (UNLIKELY(! cur_len)) {
 769                 break;
 770             }
 771             x += cur_len;
 772             outlen++;
 773         }
 774
 775         if (el)
 776             *el = outlen;
 777
 778         if (ep) {
 779             *ep = x;
 780         }
 781
 782         return (x == send);
 783     }
 784 }
 785
 786 /*
 787
 788 =for apidoc is_strict_utf8_string_loc
 789
 790 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
 791 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 792 "utf8ness success") in the C<ep> pointer.
 793
 794 See also C<L</is_strict_utf8_string_loclen>>.
 795
 796 =cut
 797 */
 798
 799 #define is_strict_utf8_string_loc(s, len, ep)                               \
 800                                 is_strict_utf8_string_loclen(s, len, ep, 0)
 801
 802 /*
 803
 804 =for apidoc is_strict_utf8_string_loclen
 805
 806 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
 807 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 808 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
 809 encoded characters in the C<el> pointer.
 810
 811 See also C<L</is_strict_utf8_string_loc>>.
 812
 813 =cut
 814 */
 815
 816 PERL_STATIC_INLINE bool
 817 S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 818 {
 819     const U8 * first_variant;
 820
 821     PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
 822
 823     if (len == 0) {
 824         len = strlen((const char *) s);
 825     }
 826
 827     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 828         if (el)
 829             *el = len;
 830
 831         if (ep) {
 832             *ep = s + len;
 833         }
 834
 835         return TRUE;
 836     }
 837
 838     {
 839         const U8* const send = s + len;
 840         const U8* x = first_variant;
 841         STRLEN outlen = first_variant - s;
 842
 843         while (x < send) {
 844             const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
 845             if (UNLIKELY(! cur_len)) {
 846                 break;
 847             }
 848             x += cur_len;
 849             outlen++;
 850         }
 851
 852         if (el)
 853             *el = outlen;
 854
 855         if (ep) {
 856             *ep = x;
 857         }
 858
 859         return (x == send);
 860     }
 861 }
 862
 863 /*
 864
 865 =for apidoc is_c9strict_utf8_string_loc
 866
 867 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
 868 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 869 "utf8ness success") in the C<ep> pointer.
 870
 871 See also C<L</is_c9strict_utf8_string_loclen>>.
 872
 873 =cut
 874 */
 875
 876 #define is_c9strict_utf8_string_loc(s, len, ep)                             \
 877                             is_c9strict_utf8_string_loclen(s, len, ep, 0)
 878
 879 /*
 880
 881 =for apidoc is_c9strict_utf8_string_loclen
 882
 883 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
 884 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 885 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
 886 characters in the C<el> pointer.
 887
 888 See also C<L</is_c9strict_utf8_string_loc>>.
 889
 890 =cut
 891 */
 892
 893 PERL_STATIC_INLINE bool
 894 S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 895 {
 896     const U8 * first_variant;
 897
 898     PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
 899
 900     if (len == 0) {
 901         len = strlen((const char *) s);
 902     }
 903
 904     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 905         if (el)
 906             *el = len;
 907
 908         if (ep) {
 909             *ep = s + len;
 910         }
 911
 912         return TRUE;
 913     }
 914
 915     {
 916         const U8* const send = s + len;
 917         const U8* x = first_variant;
 918         STRLEN outlen = first_variant - s;
 919
 920         while (x < send) {
 921             const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
 922             if (UNLIKELY(! cur_len)) {
 923                 break;
 924             }
 925             x += cur_len;
 926             outlen++;
 927         }
 928
 929         if (el)
 930             *el = outlen;
 931
 932         if (ep) {
 933             *ep = x;
 934         }
 935
 936         return (x == send);
 937     }
 938 }
 939
 940 /*
 941
 942 =for apidoc is_utf8_string_loc_flags
 943
 944 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
 945 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 946 "utf8ness success") in the C<ep> pointer.
 947
 948 See also C<L</is_utf8_string_loclen_flags>>.
 949
 950 =cut
 951 */
 952
 953 #define is_utf8_string_loc_flags(s, len, ep, flags)                         \
 954                         is_utf8_string_loclen_flags(s, len, ep, 0, flags)
 955
 956
 957 /* The above 3 actual functions could have been moved into the more general one
 958  * just below, and made #defines that call it with the right 'flags'.  They are
 959  * currently kept separate to increase their chances of getting inlined */
 960
 961 /*
 962
 963 =for apidoc is_utf8_string_loclen_flags
 964
 965 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
 966 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 967 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
 968 encoded characters in the C<el> pointer.
 969
 970 See also C<L</is_utf8_string_loc_flags>>.
 971
 972 =cut
 973 */
 974
 975 PERL_STATIC_INLINE bool
 976 S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
 977 {
 978     const U8 * first_variant;
 979
 980     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
 981     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
 982                           |UTF8_DISALLOW_PERL_EXTENDED)));
 983
 984     if (len == 0) {
 985         len = strlen((const char *) s);
 986     }
 987
 988     if (flags == 0) {
 989         return is_utf8_string_loclen(s, len, ep, el);
 990     }
 991
 992     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 993                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
 994     {
 995         return is_strict_utf8_string_loclen(s, len, ep, el);
 996     }
 997
 998     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 999                                     == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1000     {
1001         return is_c9strict_utf8_string_loclen(s, len, ep, el);
1002     }
1003
1004     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1005         if (el)
1006             *el = len;
1007
1008         if (ep) {
1009             *ep = s + len;
1010         }
1011
1012         return TRUE;
1013     }
1014
1015     {
1016         const U8* send = s + len;
1017         const U8* x = first_variant;
1018         STRLEN outlen = first_variant - s;
1019
1020         while (x < send) {
1021             const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1022             if (UNLIKELY(! cur_len)) {
1023                 break;
1024             }
1025             x += cur_len;
1026             outlen++;
1027         }
1028
1029         if (el)
1030             *el = outlen;
1031
1032         if (ep) {
1033             *ep = x;
1034         }
1035
1036         return (x == send);
1037     }
1038 }
1039
1040 /*
1041 =for apidoc utf8_distance
1042
1043 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1044 and C<b>.
1045
1046 WARNING: use only if you *know* that the pointers point inside the
1047 same UTF-8 buffer.
1048
1049 =cut
1050 */
1051
1052 PERL_STATIC_INLINE IV
1053 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1054 {
1055     PERL_ARGS_ASSERT_UTF8_DISTANCE;
1056
1057     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1058 }
1059
1060 /*
1061 =for apidoc utf8_hop
1062
1063 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1064 forward or backward.
1065
1066 WARNING: do not use the following unless you *know* C<off> is within
1067 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1068 on the first byte of character or just after the last byte of a character.
1069
1070 =cut
1071 */
1072
1073 PERL_STATIC_INLINE U8 *
1074 Perl_utf8_hop(const U8 *s, SSize_t off)
1075 {
1076     PERL_ARGS_ASSERT_UTF8_HOP;
1077
1078     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1079      * the bitops (especially ~) can create illegal UTF-8.
1080      * In other words: in Perl UTF-8 is not just for Unicode. */
1081
1082     if (off >= 0) {
1083         while (off--)
1084             s += UTF8SKIP(s);
1085     }
1086     else {
1087         while (off++) {
1088             s--;
1089             while (UTF8_IS_CONTINUATION(*s))
1090                 s--;
1091         }
1092     }
1093     GCC_DIAG_IGNORE(-Wcast-qual);
1094     return (U8 *)s;
1095     GCC_DIAG_RESTORE;
1096 }
1097
1098 /*
1099 =for apidoc utf8_hop_forward
1100
1101 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1102 forward.
1103
1104 C<off> must be non-negative.
1105
1106 C<s> must be before or equal to C<end>.
1107
1108 When moving forward it will not move beyond C<end>.
1109
1110 Will not exceed this limit even if the string is not valid "UTF-8".
1111
1112 =cut
1113 */
1114
1115 PERL_STATIC_INLINE U8 *
1116 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1117 {
1118     PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1119
1120     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1121      * the bitops (especially ~) can create illegal UTF-8.
1122      * In other words: in Perl UTF-8 is not just for Unicode. */
1123
1124     assert(s <= end);
1125     assert(off >= 0);
1126
1127     while (off--) {
1128         STRLEN skip = UTF8SKIP(s);
1129         if ((STRLEN)(end - s) <= skip) {
1130             GCC_DIAG_IGNORE(-Wcast-qual);
1131             return (U8 *)end;
1132             GCC_DIAG_RESTORE;
1133         }
1134         s += skip;
1135     }
1136
1137     GCC_DIAG_IGNORE(-Wcast-qual);
1138     return (U8 *)s;
1139     GCC_DIAG_RESTORE;
1140 }
1141
1142 /*
1143 =for apidoc utf8_hop_back
1144
1145 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1146 backward.
1147
1148 C<off> must be non-positive.
1149
1150 C<s> must be after or equal to C<start>.
1151
1152 When moving backward it will not move before C<start>.
1153
1154 Will not exceed this limit even if the string is not valid "UTF-8".
1155
1156 =cut
1157 */
1158
1159 PERL_STATIC_INLINE U8 *
1160 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1161 {
1162     PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1163
1164     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1165      * the bitops (especially ~) can create illegal UTF-8.
1166      * In other words: in Perl UTF-8 is not just for Unicode. */
1167
1168     assert(start <= s);
1169     assert(off <= 0);
1170
1171     while (off++ && s > start) {
1172         s--;
1173         while (UTF8_IS_CONTINUATION(*s) && s > start)
1174             s--;
1175     }
1176
1177     GCC_DIAG_IGNORE(-Wcast-qual);
1178     return (U8 *)s;
1179     GCC_DIAG_RESTORE;
1180 }
1181
1182 /*
1183 =for apidoc utf8_hop_safe
1184
1185 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1186 either forward or backward.
1187
1188 When moving backward it will not move before C<start>.
1189
1190 When moving forward it will not move beyond C<end>.
1191
1192 Will not exceed those limits even if the string is not valid "UTF-8".
1193
1194 =cut
1195 */
1196
1197 PERL_STATIC_INLINE U8 *
1198 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1199 {
1200     PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1201
1202     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1203      * the bitops (especially ~) can create illegal UTF-8.
1204      * In other words: in Perl UTF-8 is not just for Unicode. */
1205
1206     assert(start <= s && s <= end);
1207
1208     if (off >= 0) {
1209         return utf8_hop_forward(s, off, end);
1210     }
1211     else {
1212         return utf8_hop_back(s, off, start);
1213     }
1214 }
1215
1216 /*
1217
1218 =for apidoc is_utf8_valid_partial_char
1219
1220 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1221 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1222 points.  Otherwise, it returns 1 if there exists at least one non-empty
1223 sequence of bytes that when appended to sequence C<s>, starting at position
1224 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1225 otherwise returns 0.
1226
1227 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1228 point.
1229
1230 This is useful when a fixed-length buffer is being tested for being well-formed
1231 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1232 it is split somewhere in the middle of the final code point's UTF-8
1233 representation.  (Presumably when the buffer is refreshed with the next chunk
1234 of data, the new first bytes will complete the partial code point.)   This
1235 function is used to verify that the final bytes in the current buffer are in
1236 fact the legal beginning of some code point, so that if they aren't, the
1237 failure can be signalled without having to wait for the next read.
1238
1239 =cut
1240 */
1241 #define is_utf8_valid_partial_char(s, e)                                    \
1242                                 is_utf8_valid_partial_char_flags(s, e, 0)
1243
1244 /*
1245
1246 =for apidoc is_utf8_valid_partial_char_flags
1247
1248 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1249 or not the input is a valid UTF-8 encoded partial character, but it takes an
1250 extra parameter, C<flags>, which can further restrict which code points are
1251 considered valid.
1252
1253 If C<flags> is 0, this behaves identically to
1254 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
1255 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
1256 there is any sequence of bytes that can complete the input partial character in
1257 such a way that a non-prohibited character is formed, the function returns
1258 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
1259 partial character input.  But many  of the other possible excluded types can be
1260 determined from just the first one or two bytes.
1261
1262 =cut
1263  */
1264
1265 PERL_STATIC_INLINE bool
1266 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1267 {
1268     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1269
1270     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1271                           |UTF8_DISALLOW_PERL_EXTENDED)));
1272
1273     if (s >= e || s + UTF8SKIP(s) <= e) {
1274         return FALSE;
1275     }
1276
1277     return cBOOL(_is_utf8_char_helper(s, e, flags));
1278 }
1279
1280 /*
1281
1282 =for apidoc is_utf8_fixed_width_buf_flags
1283
1284 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1285 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1286 otherwise it returns FALSE.
1287
1288 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1289 without restriction.  If the final few bytes of the buffer do not form a
1290 complete code point, this will return TRUE anyway, provided that
1291 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1292
1293 If C<flags> in non-zero, it can be any combination of the
1294 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1295 same meanings.
1296
1297 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1298 returns FALSE if the final few bytes of the string don't form a complete code
1299 point.
1300
1301 =cut
1302  */
1303 #define is_utf8_fixed_width_buf_flags(s, len, flags)                        \
1304                 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1305
1306 /*
1307
1308 =for apidoc is_utf8_fixed_width_buf_loc_flags
1309
1310 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1311 failure in the C<ep> pointer.  If the function returns TRUE, C<*ep> will point
1312 to the beginning of any partial character at the end of the buffer; if there is
1313 no partial character C<*ep> will contain C<s>+C<len>.
1314
1315 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1316
1317 =cut
1318 */
1319
1320 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)               \
1321                 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1322
1323 /*
1324
1325 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1326
1327 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1328 complete, valid characters found in the C<el> pointer.
1329
1330 =cut
1331 */
1332
1333 PERL_STATIC_INLINE bool
1334 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1335                                        STRLEN len,
1336                                        const U8 **ep,
1337                                        STRLEN *el,
1338                                        const U32 flags)
1339 {
1340     const U8 * maybe_partial;
1341
1342     PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1343
1344     if (! ep) {
1345         ep  = &maybe_partial;
1346     }
1347
1348     /* If it's entirely valid, return that; otherwise see if the only error is
1349      * that the final few bytes are for a partial character */
1350     return    is_utf8_string_loclen_flags(s, len, ep, el, flags)
1351            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1352 }
1353
1354 /* ------------------------------- perl.h ----------------------------- */
1355
1356 /*
1357 =head1 Miscellaneous Functions
1358
1359 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1360
1361 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1362 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1363
1364 Return TRUE if the name is safe.
1365
1366 Used by the C<IS_SAFE_SYSCALL()> macro.
1367
1368 =cut
1369 */
1370
1371 PERL_STATIC_INLINE bool
1372 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1373     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1374      * perl itself uses xce*() functions which accept 8-bit strings.
1375      */
1376
1377     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1378
1379     if (len > 1) {
1380         char *null_at;
1381         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1382                 SETERRNO(ENOENT, LIB_INVARG);
1383                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1384                                    "Invalid \\0 character in %s for %s: %s\\0%s",
1385                                    what, op_name, pv, null_at+1);
1386                 return FALSE;
1387         }
1388     }
1389
1390     return TRUE;
1391 }
1392
1393 /*
1394
1395 Return true if the supplied filename has a newline character
1396 immediately before the first (hopefully only) NUL.
1397
1398 My original look at this incorrectly used the len from SvPV(), but
1399 that's incorrect, since we allow for a NUL in pv[len-1].
1400
1401 So instead, strlen() and work from there.
1402
1403 This allow for the user reading a filename, forgetting to chomp it,
1404 then calling:
1405
1406   open my $foo, "$file\0";
1407
1408 */
1409
1410 #ifdef PERL_CORE
1411
1412 PERL_STATIC_INLINE bool
1413 S_should_warn_nl(const char *pv) {
1414     STRLEN len;
1415
1416     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1417
1418     len = strlen(pv);
1419
1420     return len > 0 && pv[len-1] == '\n';
1421 }
1422
1423 #endif
1424
1425 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1426
1427 #define MAX_CHARSET_NAME_LENGTH 2
1428
1429 PERL_STATIC_INLINE const char *
1430 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1431 {
1432     /* Returns a string that corresponds to the name of the regex character set
1433      * given by 'flags', and *lenp is set the length of that string, which
1434      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1435
1436     *lenp = 1;
1437     switch (get_regex_charset(flags)) {
1438         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1439         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
1440         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1441         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1442         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1443             *lenp = 2;
1444             return ASCII_MORE_RESTRICT_PAT_MODS;
1445     }
1446     /* The NOT_REACHED; hides an assert() which has a rather complex
1447      * definition in perl.h. */
1448     NOT_REACHED; /* NOTREACHED */
1449     return "?";     /* Unknown */
1450 }
1451
1452 /*
1453
1454 Return false if any get magic is on the SV other than taint magic.
1455
1456 */
1457
1458 PERL_STATIC_INLINE bool
1459 S_sv_only_taint_gmagic(SV *sv) {
1460     MAGIC *mg = SvMAGIC(sv);
1461
1462     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1463
1464     while (mg) {
1465         if (mg->mg_type != PERL_MAGIC_taint
1466             && !(mg->mg_flags & MGf_GSKIP)
1467             && mg->mg_virtual->svt_get) {
1468             return FALSE;
1469         }
1470         mg = mg->mg_moremagic;
1471     }
1472
1473     return TRUE;
1474 }
1475
1476 /* ------------------ cop.h ------------------------------------------- */
1477
1478
1479 /* Enter a block. Push a new base context and return its address. */
1480
1481 PERL_STATIC_INLINE PERL_CONTEXT *
1482 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1483 {
1484     PERL_CONTEXT * cx;
1485
1486     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1487
1488     CXINC;
1489     cx = CX_CUR();
1490     cx->cx_type        = type;
1491     cx->blk_gimme      = gimme;
1492     cx->blk_oldsaveix  = saveix;
1493     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
1494     cx->blk_oldcop     = PL_curcop;
1495     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
1496     cx->blk_oldscopesp = PL_scopestack_ix;
1497     cx->blk_oldpm      = PL_curpm;
1498     cx->blk_old_tmpsfloor = PL_tmps_floor;
1499
1500     PL_tmps_floor        = PL_tmps_ix;
1501     CX_DEBUG(cx, "PUSH");
1502     return cx;
1503 }
1504
1505
1506 /* Exit a block (RETURN and LAST). */
1507
1508 PERL_STATIC_INLINE void
1509 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1510 {
1511     PERL_ARGS_ASSERT_CX_POPBLOCK;
1512
1513     CX_DEBUG(cx, "POP");
1514     /* these 3 are common to cx_popblock and cx_topblock */
1515     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1516     PL_scopestack_ix = cx->blk_oldscopesp;
1517     PL_curpm         = cx->blk_oldpm;
1518
1519     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1520      * and leaves a CX entry lying around for repeated use, so
1521      * skip for multicall */                  \
1522     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1523             || PL_savestack_ix == cx->blk_oldsaveix);
1524     PL_curcop     = cx->blk_oldcop;
1525     PL_tmps_floor = cx->blk_old_tmpsfloor;
1526 }
1527
1528 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1529  * Whereas cx_popblock() restores the state to the point just before
1530  * cx_pushblock() was called,  cx_topblock() restores it to the point just
1531  * *after* cx_pushblock() was called. */
1532
1533 PERL_STATIC_INLINE void
1534 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1535 {
1536     PERL_ARGS_ASSERT_CX_TOPBLOCK;
1537
1538     CX_DEBUG(cx, "TOP");
1539     /* these 3 are common to cx_popblock and cx_topblock */
1540     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1541     PL_scopestack_ix = cx->blk_oldscopesp;
1542     PL_curpm         = cx->blk_oldpm;
1543
1544     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
1545 }
1546
1547
1548 PERL_STATIC_INLINE void
1549 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1550 {
1551     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1552
1553     PERL_ARGS_ASSERT_CX_PUSHSUB;
1554
1555     PERL_DTRACE_PROBE_ENTRY(cv);
1556     cx->blk_sub.cv = cv;
1557     cx->blk_sub.olddepth = CvDEPTH(cv);
1558     cx->blk_sub.prevcomppad = PL_comppad;
1559     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1560     cx->blk_sub.retop = retop;
1561     SvREFCNT_inc_simple_void_NN(cv);
1562     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1563 }
1564
1565
1566 /* subsets of cx_popsub() */
1567
1568 PERL_STATIC_INLINE void
1569 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1570 {
1571     CV *cv;
1572
1573     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1574     assert(CxTYPE(cx) == CXt_SUB);
1575
1576     PL_comppad = cx->blk_sub.prevcomppad;
1577     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1578     cv = cx->blk_sub.cv;
1579     CvDEPTH(cv) = cx->blk_sub.olddepth;
1580     cx->blk_sub.cv = NULL;
1581     SvREFCNT_dec(cv);
1582 }
1583
1584
1585 /* handle the @_ part of leaving a sub */
1586
1587 PERL_STATIC_INLINE void
1588 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1589 {
1590     AV *av;
1591
1592     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1593     assert(CxTYPE(cx) == CXt_SUB);
1594     assert(AvARRAY(MUTABLE_AV(
1595         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1596                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1597
1598     CX_POP_SAVEARRAY(cx);
1599     av = MUTABLE_AV(PAD_SVl(0));
1600     if (UNLIKELY(AvREAL(av)))
1601         /* abandon @_ if it got reified */
1602         clear_defarray(av, 0);
1603     else {
1604         CLEAR_ARGARRAY(av);
1605     }
1606 }
1607
1608
1609 PERL_STATIC_INLINE void
1610 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1611 {
1612     PERL_ARGS_ASSERT_CX_POPSUB;
1613     assert(CxTYPE(cx) == CXt_SUB);
1614
1615     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1616
1617     if (CxHASARGS(cx))
1618         cx_popsub_args(cx);
1619     cx_popsub_common(cx);
1620 }
1621
1622
1623 PERL_STATIC_INLINE void
1624 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1625 {
1626     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1627
1628     cx->blk_format.cv          = cv;
1629     cx->blk_format.retop       = retop;
1630     cx->blk_format.gv          = gv;
1631     cx->blk_format.dfoutgv     = PL_defoutgv;
1632     cx->blk_format.prevcomppad = PL_comppad;
1633     cx->blk_u16                = 0;
1634
1635     SvREFCNT_inc_simple_void_NN(cv);
1636     CvDEPTH(cv)++;
1637     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1638 }
1639
1640
1641 PERL_STATIC_INLINE void
1642 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1643 {
1644     CV *cv;
1645     GV *dfout;
1646
1647     PERL_ARGS_ASSERT_CX_POPFORMAT;
1648     assert(CxTYPE(cx) == CXt_FORMAT);
1649
1650     dfout = cx->blk_format.dfoutgv;
1651     setdefout(dfout);
1652     cx->blk_format.dfoutgv = NULL;
1653     SvREFCNT_dec_NN(dfout);
1654
1655     PL_comppad = cx->blk_format.prevcomppad;
1656     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1657     cv = cx->blk_format.cv;
1658     cx->blk_format.cv = NULL;
1659     --CvDEPTH(cv);
1660     SvREFCNT_dec_NN(cv);
1661 }
1662
1663
1664 PERL_STATIC_INLINE void
1665 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1666 {
1667     PERL_ARGS_ASSERT_CX_PUSHEVAL;
1668
1669     cx->blk_eval.retop         = retop;
1670     cx->blk_eval.old_namesv    = namesv;
1671     cx->blk_eval.old_eval_root = PL_eval_root;
1672     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
1673     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
1674     cx->blk_eval.cur_top_env   = PL_top_env;
1675
1676     assert(!(PL_in_eval     & ~ 0x3F));
1677     assert(!(PL_op->op_type & ~0x1FF));
1678     cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1679 }
1680
1681
1682 PERL_STATIC_INLINE void
1683 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1684 {
1685     SV *sv;
1686
1687     PERL_ARGS_ASSERT_CX_POPEVAL;
1688     assert(CxTYPE(cx) == CXt_EVAL);
1689
1690     PL_in_eval = CxOLD_IN_EVAL(cx);
1691     assert(!(PL_in_eval & 0xc0));
1692     PL_eval_root = cx->blk_eval.old_eval_root;
1693     sv = cx->blk_eval.cur_text;
1694     if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1695         cx->blk_eval.cur_text = NULL;
1696         SvREFCNT_dec_NN(sv);
1697     }
1698
1699     sv = cx->blk_eval.old_namesv;
1700     if (sv) {
1701         cx->blk_eval.old_namesv = NULL;
1702         SvREFCNT_dec_NN(sv);
1703     }
1704 }
1705
1706
1707 /* push a plain loop, i.e.
1708  *     { block }
1709  *     while (cond) { block }
1710  *     for (init;cond;continue) { block }
1711  * This loop can be last/redo'ed etc.
1712  */
1713
1714 PERL_STATIC_INLINE void
1715 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1716 {
1717     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1718     cx->blk_loop.my_op = cLOOP;
1719 }
1720
1721
1722 /* push a true for loop, i.e.
1723  *     for var (list) { block }
1724  */
1725
1726 PERL_STATIC_INLINE void
1727 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1728 {
1729     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1730
1731     /* this one line is common with cx_pushloop_plain */
1732     cx->blk_loop.my_op = cLOOP;
1733
1734     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1735     cx->blk_loop.itersave      = itersave;
1736 #ifdef USE_ITHREADS
1737     cx->blk_loop.oldcomppad = PL_comppad;
1738 #endif
1739 }
1740
1741
1742 /* pop all loop types, including plain */
1743
1744 PERL_STATIC_INLINE void
1745 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1746 {
1747     PERL_ARGS_ASSERT_CX_POPLOOP;
1748
1749     assert(CxTYPE_is_LOOP(cx));
1750     if (  CxTYPE(cx) == CXt_LOOP_ARY
1751        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1752     {
1753         /* Free ary or cur. This assumes that state_u.ary.ary
1754          * aligns with state_u.lazysv.cur. See cx_dup() */
1755         SV *sv = cx->blk_loop.state_u.lazysv.cur;
1756         cx->blk_loop.state_u.lazysv.cur = NULL;
1757         SvREFCNT_dec_NN(sv);
1758         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1759             sv = cx->blk_loop.state_u.lazysv.end;
1760             cx->blk_loop.state_u.lazysv.end = NULL;
1761             SvREFCNT_dec_NN(sv);
1762         }
1763     }
1764     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1765         SV *cursv;
1766         SV **svp = (cx)->blk_loop.itervar_u.svp;
1767         if ((cx->cx_type & CXp_FOR_GV))
1768             svp = &GvSV((GV*)svp);
1769         cursv = *svp;
1770         *svp = cx->blk_loop.itersave;
1771         cx->blk_loop.itersave = NULL;
1772         SvREFCNT_dec(cursv);
1773     }
1774 }
1775
1776
1777 PERL_STATIC_INLINE void
1778 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1779 {
1780     PERL_ARGS_ASSERT_CX_PUSHWHEN;
1781
1782     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1783 }
1784
1785
1786 PERL_STATIC_INLINE void
1787 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1788 {
1789     PERL_ARGS_ASSERT_CX_POPWHEN;
1790     assert(CxTYPE(cx) == CXt_WHEN);
1791
1792     PERL_UNUSED_ARG(cx);
1793     PERL_UNUSED_CONTEXT;
1794     /* currently NOOP */
1795 }
1796
1797
1798 PERL_STATIC_INLINE void
1799 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1800 {
1801     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1802
1803     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1804     cx->blk_givwhen.defsv_save = orig_defsv;
1805 }
1806
1807
1808 PERL_STATIC_INLINE void
1809 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1810 {
1811     SV *sv;
1812
1813     PERL_ARGS_ASSERT_CX_POPGIVEN;
1814     assert(CxTYPE(cx) == CXt_GIVEN);
1815
1816     sv = GvSV(PL_defgv);
1817     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1818     cx->blk_givwhen.defsv_save = NULL;
1819     SvREFCNT_dec(sv);
1820 }
1821
1822 /* ------------------ util.h ------------------------------------------- */
1823
1824 /*
1825 =head1 Miscellaneous Functions
1826
1827 =for apidoc foldEQ
1828
1829 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1830 same
1831 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
1832 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
1833 range bytes match only themselves.
1834
1835 =cut
1836 */
1837
1838 PERL_STATIC_INLINE I32
1839 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1840 {
1841     const U8 *a = (const U8 *)s1;
1842     const U8 *b = (const U8 *)s2;
1843
1844     PERL_ARGS_ASSERT_FOLDEQ;
1845
1846     assert(len >= 0);
1847
1848     while (len--) {
1849         if (*a != *b && *a != PL_fold[*b])
1850             return 0;
1851         a++,b++;
1852     }
1853     return 1;
1854 }
1855
1856 PERL_STATIC_INLINE I32
1857 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1858 {
1859     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
1860      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1861      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
1862      * does it check that the strings each have at least 'len' characters */
1863
1864     const U8 *a = (const U8 *)s1;
1865     const U8 *b = (const U8 *)s2;
1866
1867     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1868
1869     assert(len >= 0);
1870
1871     while (len--) {
1872         if (*a != *b && *a != PL_fold_latin1[*b]) {
1873             return 0;
1874         }
1875         a++, b++;
1876     }
1877     return 1;
1878 }
1879
1880 /*
1881 =for apidoc foldEQ_locale
1882
1883 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1884 same case-insensitively in the current locale; false otherwise.
1885
1886 =cut
1887 */
1888
1889 PERL_STATIC_INLINE I32
1890 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1891 {
1892     dVAR;
1893     const U8 *a = (const U8 *)s1;
1894     const U8 *b = (const U8 *)s2;
1895
1896     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1897
1898     assert(len >= 0);
1899
1900     while (len--) {
1901         if (*a != *b && *a != PL_fold_locale[*b])
1902             return 0;
1903         a++,b++;
1904     }
1905     return 1;
1906 }
1907
1908 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
1909
1910 PERL_STATIC_INLINE void *
1911 S_my_memrchr(const char * s, const char c, const STRLEN len)
1912 {
1913     /* memrchr(), since many platforms lack it */
1914
1915     const char * t = s + len - 1;
1916
1917     PERL_ARGS_ASSERT_MY_MEMRCHR;
1918
1919     while (t >= s) {
1920         if (*t == c) {
1921             return (void *) t;
1922         }
1923         t--;
1924     }
1925
1926     return NULL;
1927 }
1928
1929 #endif
1930
1931 /*
1932  * ex: set ts=8 sts=4 sw=4 et:
1933  */