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