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