inline.h

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