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 GCC_DIAG_IGNORE_DECL(-Wunused-function);
 248 static void
 249 S_croak_memory_wrap(void)
 250 {
 251     Perl_croak_nocontext("%s",PL_memory_wrap);
 252 }
 253 GCC_DIAG_RESTORE_DECL;
 254
 255 /* ------------------------------- utf8.h ------------------------------- */
 256
 257 /*
 258 =head1 Unicode Support
 259 */
 260
 261 PERL_STATIC_INLINE void
 262 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
 263 {
 264     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
 265      * encoded string at '*dest', updating '*dest' to include it */
 266
 267     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
 268
 269     if (NATIVE_BYTE_IS_INVARIANT(byte))
 270         *((*dest)++) = byte;
 271     else {
 272         *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
 273         *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
 274     }
 275 }
 276
 277 /*
 278 =for apidoc valid_utf8_to_uvchr
 279 Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
 280 the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
 281 it passes C<L</isUTF8_CHAR>>.  Surrogates, non-character code points, and
 282 non-Unicode code points are allowed.
 283
 284 =cut
 285
 286  */
 287
 288 PERL_STATIC_INLINE UV
 289 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
 290 {
 291     const UV expectlen = UTF8SKIP(s);
 292     const U8* send = s + expectlen;
 293     UV uv = *s;
 294
 295     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
 296
 297     if (retlen) {
 298         *retlen = expectlen;
 299     }
 300
 301     /* An invariant is trivially returned */
 302     if (expectlen == 1) {
 303         return uv;
 304     }
 305
 306     /* Remove the leading bits that indicate the number of bytes, leaving just
 307      * the bits that are part of the value */
 308     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
 309
 310     /* Now, loop through the remaining bytes, accumulating each into the
 311      * working total as we go.  (I khw tried unrolling the loop for up to 4
 312      * bytes, but there was no performance improvement) */
 313     for (++s; s < send; s++) {
 314         uv = UTF8_ACCUMULATE(uv, *s);
 315     }
 316
 317     return UNI_TO_NATIVE(uv);
 318
 319 }
 320
 321 /*
 322 =for apidoc is_utf8_invariant_string
 323
 324 Returns TRUE if the first C<len> bytes of the string C<s> are the same
 325 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
 326 EBCDIC machines); otherwise it returns FALSE.  That is, it returns TRUE if they
 327 are UTF-8 invariant.  On ASCII-ish machines, all the ASCII characters and only
 328 the ASCII characters fit this definition.  On EBCDIC machines, the ASCII-range
 329 characters are invariant, but so also are the C1 controls.
 330
 331 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
 332 use this option, that C<s> can't have embedded C<NUL> characters and has to
 333 have a terminating C<NUL> byte).
 334
 335 See also
 336 C<L</is_utf8_string>>,
 337 C<L</is_utf8_string_flags>>,
 338 C<L</is_utf8_string_loc>>,
 339 C<L</is_utf8_string_loc_flags>>,
 340 C<L</is_utf8_string_loclen>>,
 341 C<L</is_utf8_string_loclen_flags>>,
 342 C<L</is_utf8_fixed_width_buf_flags>>,
 343 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 344 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 345 C<L</is_strict_utf8_string>>,
 346 C<L</is_strict_utf8_string_loc>>,
 347 C<L</is_strict_utf8_string_loclen>>,
 348 C<L</is_c9strict_utf8_string>>,
 349 C<L</is_c9strict_utf8_string_loc>>,
 350 and
 351 C<L</is_c9strict_utf8_string_loclen>>.
 352
 353 =cut
 354
 355 */
 356
 357 #define is_utf8_invariant_string(s, len)                                    \
 358                                 is_utf8_invariant_string_loc(s, len, NULL)
 359
 360 /*
 361 =for apidoc is_utf8_invariant_string_loc
 362
 363 Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
 364 the first UTF-8 variant character in the C<ep> pointer; if all characters are
 365 UTF-8 invariant, this function does not change the contents of C<*ep>.
 366
 367 =cut
 368
 369 */
 370
 371 PERL_STATIC_INLINE bool
 372 S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
 373 {
 374     const U8* send;
 375     const U8* x = s;
 376
 377     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
 378
 379     if (len == 0) {
 380         len = strlen((const char *)s);
 381     }
 382
 383     send = s + len;
 384
 385 /* This looks like 0x010101... */
 386 #  define PERL_COUNT_MULTIPLIER   (~ (UINTMAX_C(0)) / 0xFF)
 387
 388 /* This looks like 0x808080... */
 389 #  define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
 390 #  define PERL_WORDSIZE            sizeof(PERL_COUNT_MULTIPLIER)
 391 #  define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
 392
 393 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
 394  * or'ing together the lowest bits of 'x'.  Hopefully the final term gets
 395  * optimized out completely on a 32-bit system, and its mask gets optimized out
 396  * on a 64-bit system */
 397 #  define PERL_IS_SUBWORD_ADDR(x) (1 & (       PTR2nat(x)                     \
 398                                       |   (  PTR2nat(x) >> 1)                 \
 399                                       | ( ( (PTR2nat(x)                       \
 400                                            & PERL_WORD_BOUNDARY_MASK) >> 2))))
 401
 402 #ifndef EBCDIC
 403
 404     /* Do the word-at-a-time iff there is at least one usable full word.  That
 405      * means that after advancing to a word boundary, there still is at least a
 406      * full word left.  The number of bytes needed to advance is 'wordsize -
 407      * offset' unless offset is 0. */
 408     if ((STRLEN) (send - x) >= PERL_WORDSIZE
 409
 410                             /* This term is wordsize if subword; 0 if not */
 411                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
 412
 413                             /* 'offset' */
 414                           - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
 415     {
 416
 417         /* Process per-byte until reach word boundary.  XXX This loop could be
 418          * eliminated if we knew that this platform had fast unaligned reads */
 419         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
 420             if (! UTF8_IS_INVARIANT(*x)) {
 421                 if (ep) {
 422                     *ep = x;
 423                 }
 424
 425                 return FALSE;
 426             }
 427             x++;
 428         }
 429
 430         /* Here, we know we have at least one full word to process.  Process
 431          * per-word as long as we have at least a full word left */
 432         do {
 433             if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK)  {
 434
 435                 /* Found a variant.  Just return if caller doesn't want its
 436                  * exact position */
 437                 if (! ep) {
 438                     return FALSE;
 439                 }
 440
 441 #  if   BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    \
 442      || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
 443
 444                 *ep = x + _variant_byte_number(* (PERL_UINTMAX_T *) x);
 445                 assert(*ep >= s && *ep < send);
 446
 447                 return FALSE;
 448
 449 #  else   /* If weird byte order, drop into next loop to do byte-at-a-time
 450            checks. */
 451
 452                 break;
 453 #  endif
 454             }
 455
 456             x += PERL_WORDSIZE;
 457
 458         } while (x + PERL_WORDSIZE <= send);
 459     }
 460
 461 #endif      /* End of ! EBCDIC */
 462
 463     /* Process per-byte */
 464     while (x < send) {
 465         if (! UTF8_IS_INVARIANT(*x)) {
 466             if (ep) {
 467                 *ep = x;
 468             }
 469
 470             return FALSE;
 471         }
 472
 473         x++;
 474     }
 475
 476     return TRUE;
 477 }
 478
 479 #ifndef EBCDIC
 480
 481 PERL_STATIC_INLINE unsigned int
 482 S__variant_byte_number(PERL_UINTMAX_T word)
 483 {
 484
 485     /* This returns the position in a word (0..7) of the first variant byte in
 486      * it.  This is a helper function.  Note that there are no branches */
 487
 488     assert(word);
 489
 490     /* Get just the msb bits of each byte */
 491     word &= PERL_VARIANTS_WORD_MASK;
 492
 493 #  ifdef USING_MSVC6    /* VC6 has some issues with the normal code, and the
 494                            easiest thing is to hide that from the callers */
 495     {
 496         unsigned int i;
 497         const U8 * s = (U8 *) &word;
 498         dTHX;
 499
 500         for (i = 0; i < sizeof(word); i++ ) {
 501             if (s[i]) {
 502                 return i;
 503             }
 504         }
 505
 506         Perl_croak(aTHX_ "panic: %s: %d: unexpected zero word\n",
 507                                  __FILE__, __LINE__);
 508     }
 509
 510 #  elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
 511
 512     /* Bytes are stored like
 513      *  Byte8 ... Byte2 Byte1
 514      *  63..56...15...8 7...0
 515      *
 516      *  Isolate the lsb;
 517      * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
 518      *
 519      * The word will look this this, with a rightmost set bit in position 's':
 520      * ('x's are don't cares)
 521      *      s
 522      *  x..x100..0
 523      *  x..xx10..0      Right shift (rightmost 0 is shifted off)
 524      *  x..xx01..1      Subtract 1, turns all the trailing zeros into 1's and
 525      *                  the 1 just to their left into a 0; the remainder is
 526      *                  untouched
 527      *  0..0011..1      The xor with x..xx10..0 clears that remainder, sets
 528      *                  bottom to all 1
 529      *  0..0100..0      Add 1 to clear the word except for the bit in 's'
 530      *
 531      * Another method is to do 'word &= -word'; but it generates a compiler
 532      * message on some platforms about taking the negative of an unsigned */
 533
 534     word >>= 1;
 535     word = 1 + (word ^ (word - 1));
 536
 537 #  elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
 538
 539     /* Bytes are stored like
 540      *  Byte1 Byte2  ... Byte8
 541      * 63..56 55..47 ... 7...0
 542      *
 543      * Isolate the msb; http://codeforces.com/blog/entry/10330
 544      *
 545      * Only the most significant set bit matters.  Or'ing word with its right
 546      * shift of 1 makes that bit and the next one to its right both 1.  Then
 547      * right shifting by 2 makes for 4 1-bits in a row. ...  We end with the
 548      * msb and all to the right being 1. */
 549     word |= word >>  1;
 550     word |= word >>  2;
 551     word |= word >>  4;
 552     word |= word >>  8;
 553     word |= word >> 16;
 554     word |= word >> 32;  /* This should get optimized out on 32-bit systems. */
 555
 556     /* Then subtracting the right shift by 1 clears all but the left-most of
 557      * the 1 bits, which is our desired result */
 558     word -= (word >> 1);
 559
 560 #  else
 561 #    error Unexpected byte order
 562 #  endif
 563
 564     /* Here 'word' has a single bit set: the  msb of the first byte in which it
 565      * is set.  Calculate that position in the word.  We can use this
 566      * specialized solution: https://stackoverflow.com/a/32339674/1626653,
 567      * assumes an 8-bit byte.  (On a 32-bit machine, the larger numbers should
 568      * just get shifted off at compile time) */
 569     word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
 570                         | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
 571                         |           (39 <<  24) |           (47 <<  16)
 572                         |           (55 <<   8) |           (63 <<   0));
 573     word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
 574
 575     /* Here, word contains the position 7..63 of that bit.  Convert to 0..7 */
 576     word = ((word + 1) >> 3) - 1;
 577
 578 #  if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
 579
 580     /* And invert the result */
 581     word = CHARBITS - word - 1;
 582
 583 #  endif
 584
 585     return (unsigned int) word;
 586 }
 587
 588 #endif
 589 #if defined(PERL_CORE) || defined(PERL_EXT)
 590
 591 /*
 592 =for apidoc variant_under_utf8_count
 593
 594 This function looks at the sequence of bytes between C<s> and C<e>, which are
 595 assumed to be encoded in ASCII/Latin1, and returns how many of them would
 596 change should the string be translated into UTF-8.  Due to the nature of UTF-8,
 597 each of these would occupy two bytes instead of the single one in the input
 598 string.  Thus, this function returns the precise number of bytes the string
 599 would expand by when translated to UTF-8.
 600
 601 Unlike most of the other functions that have C<utf8> in their name, the input
 602 to this function is NOT a UTF-8-encoded string.  The function name is slightly
 603 I<odd> to emphasize this.
 604
 605 This function is internal to Perl because khw thinks that any XS code that
 606 would want this is probably operating too close to the internals.  Presenting a
 607 valid use case could change that.
 608
 609 See also
 610 C<L<perlapi/is_utf8_invariant_string>>
 611 and
 612 C<L<perlapi/is_utf8_invariant_string_loc>>,
 613
 614 =cut
 615
 616 */
 617
 618 PERL_STATIC_INLINE Size_t
 619 S_variant_under_utf8_count(const U8* const s, const U8* const e)
 620 {
 621     const U8* x = s;
 622     Size_t count = 0;
 623
 624     PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
 625
 626 #  ifndef EBCDIC
 627
 628     /* Test if the string is long enough to use word-at-a-time.  (Logic is the
 629      * same as for is_utf8_invariant_string()) */
 630     if ((STRLEN) (e - x) >= PERL_WORDSIZE
 631                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
 632                           - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
 633     {
 634
 635         /* Process per-byte until reach word boundary.  XXX This loop could be
 636          * eliminated if we knew that this platform had fast unaligned reads */
 637         while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
 638             count += ! UTF8_IS_INVARIANT(*x++);
 639         }
 640
 641         /* Process per-word as long as we have at least a full word left */
 642         do {    /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
 643                    explanation of how this works */
 644             PERL_UINTMAX_T increment
 645                 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
 646                       * PERL_COUNT_MULTIPLIER)
 647                     >> ((PERL_WORDSIZE - 1) * CHARBITS);
 648             count += (Size_t) increment;
 649             x += PERL_WORDSIZE;
 650         } while (x + PERL_WORDSIZE <= e);
 651     }
 652
 653 #  endif
 654
 655     /* Process per-byte */
 656     while (x < e) {
 657         if (! UTF8_IS_INVARIANT(*x)) {
 658             count++;
 659         }
 660
 661         x++;
 662     }
 663
 664     return count;
 665 }
 666
 667 #endif
 668
 669 #ifndef PERL_IN_REGEXEC_C   /* Keep  these around for that file */
 670 #  undef PERL_WORDSIZE
 671 #  undef PERL_COUNT_MULTIPLIER
 672 #  undef PERL_WORD_BOUNDARY_MASK
 673 #  undef PERL_VARIANTS_WORD_MASK
 674 #endif
 675
 676 /*
 677 =for apidoc is_utf8_string
 678
 679 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 680 Perl-extended-UTF-8 string; returns FALSE otherwise.  If C<len> is 0, it will
 681 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
 682 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
 683 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
 684
 685 This function considers Perl's extended UTF-8 to be valid.  That means that
 686 code points above Unicode, surrogates, and non-character code points are
 687 considered valid by this function.  Use C<L</is_strict_utf8_string>>,
 688 C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
 689 code points are considered valid.
 690
 691 See also
 692 C<L</is_utf8_invariant_string>>,
 693 C<L</is_utf8_invariant_string_loc>>,
 694 C<L</is_utf8_string_loc>>,
 695 C<L</is_utf8_string_loclen>>,
 696 C<L</is_utf8_fixed_width_buf_flags>>,
 697 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 698 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 699
 700 =cut
 701 */
 702
 703 #define is_utf8_string(s, len)  is_utf8_string_loclen(s, len, NULL, NULL)
 704
 705 #if defined(PERL_CORE) || defined (PERL_EXT)
 706
 707 /*
 708 =for apidoc is_utf8_non_invariant_string
 709
 710 Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
 711 C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
 712 UTF-8; otherwise returns FALSE.
 713
 714 A TRUE return means that at least one code point represented by the sequence
 715 either is a wide character not representable as a single byte, or the
 716 representation differs depending on whether the sequence is encoded in UTF-8 or
 717 not.
 718
 719 See also
 720 C<L<perlapi/is_utf8_invariant_string>>,
 721 C<L<perlapi/is_utf8_string>>
 722
 723 =cut
 724
 725 This is commonly used to determine if a SV's UTF-8 flag should be turned on.
 726 It generally needn't be if its string is entirely UTF-8 invariant, and it
 727 shouldn't be if it otherwise contains invalid UTF-8.
 728
 729 It is an internal function because khw thinks that XS code shouldn't be working
 730 at this low a level.  A valid use case could change that.
 731
 732 */
 733
 734 PERL_STATIC_INLINE bool
 735 S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
 736 {
 737     const U8 * first_variant;
 738
 739     PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
 740
 741     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 742         return FALSE;
 743     }
 744
 745     return is_utf8_string(first_variant, len - (first_variant - s));
 746 }
 747
 748 #endif
 749
 750 /*
 751 =for apidoc is_strict_utf8_string
 752
 753 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 754 UTF-8-encoded string that is fully interchangeable by any application using
 755 Unicode rules; otherwise it returns FALSE.  If C<len> is 0, it will be
 756 calculated using C<strlen(s)> (which means if you use this option, that C<s>
 757 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
 758 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
 759
 760 This function returns FALSE for strings containing any
 761 code points above the Unicode max of 0x10FFFF, surrogate code points, or
 762 non-character code points.
 763
 764 See also
 765 C<L</is_utf8_invariant_string>>,
 766 C<L</is_utf8_invariant_string_loc>>,
 767 C<L</is_utf8_string>>,
 768 C<L</is_utf8_string_flags>>,
 769 C<L</is_utf8_string_loc>>,
 770 C<L</is_utf8_string_loc_flags>>,
 771 C<L</is_utf8_string_loclen>>,
 772 C<L</is_utf8_string_loclen_flags>>,
 773 C<L</is_utf8_fixed_width_buf_flags>>,
 774 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 775 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 776 C<L</is_strict_utf8_string_loc>>,
 777 C<L</is_strict_utf8_string_loclen>>,
 778 C<L</is_c9strict_utf8_string>>,
 779 C<L</is_c9strict_utf8_string_loc>>,
 780 and
 781 C<L</is_c9strict_utf8_string_loclen>>.
 782
 783 =cut
 784 */
 785
 786 #define is_strict_utf8_string(s, len)  is_strict_utf8_string_loclen(s, len, NULL, NULL)
 787
 788 /*
 789 =for apidoc is_c9strict_utf8_string
 790
 791 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 792 UTF-8-encoded string that conforms to
 793 L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
 794 otherwise it returns FALSE.  If C<len> is 0, it will be calculated using
 795 C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
 796 C<NUL> characters and has to have a terminating C<NUL> byte).  Note that all
 797 characters being ASCII constitute 'a valid UTF-8 string'.
 798
 799 This function returns FALSE for strings containing any code points above the
 800 Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
 801 code points per
 802 L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
 803
 804 See also
 805 C<L</is_utf8_invariant_string>>,
 806 C<L</is_utf8_invariant_string_loc>>,
 807 C<L</is_utf8_string>>,
 808 C<L</is_utf8_string_flags>>,
 809 C<L</is_utf8_string_loc>>,
 810 C<L</is_utf8_string_loc_flags>>,
 811 C<L</is_utf8_string_loclen>>,
 812 C<L</is_utf8_string_loclen_flags>>,
 813 C<L</is_utf8_fixed_width_buf_flags>>,
 814 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 815 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 816 C<L</is_strict_utf8_string>>,
 817 C<L</is_strict_utf8_string_loc>>,
 818 C<L</is_strict_utf8_string_loclen>>,
 819 C<L</is_c9strict_utf8_string_loc>>,
 820 and
 821 C<L</is_c9strict_utf8_string_loclen>>.
 822
 823 =cut
 824 */
 825
 826 #define is_c9strict_utf8_string(s, len)  is_c9strict_utf8_string_loclen(s, len, NULL, 0)
 827
 828 /*
 829 =for apidoc is_utf8_string_flags
 830
 831 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 832 UTF-8 string, subject to the restrictions imposed by C<flags>;
 833 returns FALSE otherwise.  If C<len> is 0, it will be calculated
 834 using C<strlen(s)> (which means if you use this option, that C<s> can't have
 835 embedded C<NUL> characters and has to have a terminating C<NUL> byte).  Note
 836 that all characters being ASCII constitute 'a valid UTF-8 string'.
 837
 838 If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
 839 C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
 840 as C<L</is_strict_utf8_string>>; and if C<flags> is
 841 C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
 842 C<L</is_c9strict_utf8_string>>.  Otherwise C<flags> may be any
 843 combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
 844 C<L</utf8n_to_uvchr>>, with the same meanings.
 845
 846 See also
 847 C<L</is_utf8_invariant_string>>,
 848 C<L</is_utf8_invariant_string_loc>>,
 849 C<L</is_utf8_string>>,
 850 C<L</is_utf8_string_loc>>,
 851 C<L</is_utf8_string_loc_flags>>,
 852 C<L</is_utf8_string_loclen>>,
 853 C<L</is_utf8_string_loclen_flags>>,
 854 C<L</is_utf8_fixed_width_buf_flags>>,
 855 C<L</is_utf8_fixed_width_buf_loc_flags>>,
 856 C<L</is_utf8_fixed_width_buf_loclen_flags>>,
 857 C<L</is_strict_utf8_string>>,
 858 C<L</is_strict_utf8_string_loc>>,
 859 C<L</is_strict_utf8_string_loclen>>,
 860 C<L</is_c9strict_utf8_string>>,
 861 C<L</is_c9strict_utf8_string_loc>>,
 862 and
 863 C<L</is_c9strict_utf8_string_loclen>>.
 864
 865 =cut
 866 */
 867
 868 PERL_STATIC_INLINE bool
 869 S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
 870 {
 871     const U8 * first_variant;
 872
 873     PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
 874     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
 875                           |UTF8_DISALLOW_PERL_EXTENDED)));
 876
 877     if (len == 0) {
 878         len = strlen((const char *)s);
 879     }
 880
 881     if (flags == 0) {
 882         return is_utf8_string(s, len);
 883     }
 884
 885     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 886                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
 887     {
 888         return is_strict_utf8_string(s, len);
 889     }
 890
 891     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
 892                                        == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
 893     {
 894         return is_c9strict_utf8_string(s, len);
 895     }
 896
 897     if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
 898         const U8* const send = s + len;
 899         const U8* x = first_variant;
 900
 901         while (x < send) {
 902             STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
 903             if (UNLIKELY(! cur_len)) {
 904                 return FALSE;
 905             }
 906             x += cur_len;
 907         }
 908     }
 909
 910     return TRUE;
 911 }
 912
 913 /*
 914
 915 =for apidoc is_utf8_string_loc
 916
 917 Like C<L</is_utf8_string>> but stores the location of the failure (in the
 918 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 919 "utf8ness success") in the C<ep> pointer.
 920
 921 See also C<L</is_utf8_string_loclen>>.
 922
 923 =cut
 924 */
 925
 926 #define is_utf8_string_loc(s, len, ep)  is_utf8_string_loclen(s, len, ep, 0)
 927
 928 /*
 929
 930 =for apidoc is_utf8_string_loclen
 931
 932 Like C<L</is_utf8_string>> but stores the location of the failure (in the
 933 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 934 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
 935 encoded characters in the C<el> pointer.
 936
 937 See also C<L</is_utf8_string_loc>>.
 938
 939 =cut
 940 */
 941
 942 PERL_STATIC_INLINE bool
 943 Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 944 {
 945     const U8 * first_variant;
 946
 947     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 948
 949     if (len == 0) {
 950         len = strlen((const char *) s);
 951     }
 952
 953     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
 954         if (el)
 955             *el = len;
 956
 957         if (ep) {
 958             *ep = s + len;
 959         }
 960
 961         return TRUE;
 962     }
 963
 964     {
 965         const U8* const send = s + len;
 966         const U8* x = first_variant;
 967         STRLEN outlen = first_variant - s;
 968
 969         while (x < send) {
 970             const STRLEN cur_len = isUTF8_CHAR(x, send);
 971             if (UNLIKELY(! cur_len)) {
 972                 break;
 973             }
 974             x += cur_len;
 975             outlen++;
 976         }
 977
 978         if (el)
 979             *el = outlen;
 980
 981         if (ep) {
 982             *ep = x;
 983         }
 984
 985         return (x == send);
 986     }
 987 }
 988
 989 /*
 990
 991 =for apidoc is_strict_utf8_string_loc
 992
 993 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
 994 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 995 "utf8ness success") in the C<ep> pointer.
 996
 997 See also C<L</is_strict_utf8_string_loclen>>.
 998
 999 =cut
1000 */
1001
1002 #define is_strict_utf8_string_loc(s, len, ep)                               \
1003                                 is_strict_utf8_string_loclen(s, len, ep, 0)
1004
1005 /*
1006
1007 =for apidoc is_strict_utf8_string_loclen
1008
1009 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1010 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1011 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1012 encoded characters in the C<el> pointer.
1013
1014 See also C<L</is_strict_utf8_string_loc>>.
1015
1016 =cut
1017 */
1018
1019 PERL_STATIC_INLINE bool
1020 S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1021 {
1022     const U8 * first_variant;
1023
1024     PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1025
1026     if (len == 0) {
1027         len = strlen((const char *) s);
1028     }
1029
1030     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1031         if (el)
1032             *el = len;
1033
1034         if (ep) {
1035             *ep = s + len;
1036         }
1037
1038         return TRUE;
1039     }
1040
1041     {
1042         const U8* const send = s + len;
1043         const U8* x = first_variant;
1044         STRLEN outlen = first_variant - s;
1045
1046         while (x < send) {
1047             const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1048             if (UNLIKELY(! cur_len)) {
1049                 break;
1050             }
1051             x += cur_len;
1052             outlen++;
1053         }
1054
1055         if (el)
1056             *el = outlen;
1057
1058         if (ep) {
1059             *ep = x;
1060         }
1061
1062         return (x == send);
1063     }
1064 }
1065
1066 /*
1067
1068 =for apidoc is_c9strict_utf8_string_loc
1069
1070 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1071 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1072 "utf8ness success") in the C<ep> pointer.
1073
1074 See also C<L</is_c9strict_utf8_string_loclen>>.
1075
1076 =cut
1077 */
1078
1079 #define is_c9strict_utf8_string_loc(s, len, ep)                             \
1080                             is_c9strict_utf8_string_loclen(s, len, ep, 0)
1081
1082 /*
1083
1084 =for apidoc is_c9strict_utf8_string_loclen
1085
1086 Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1087 the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1088 "utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1089 characters in the C<el> pointer.
1090
1091 See also C<L</is_c9strict_utf8_string_loc>>.
1092
1093 =cut
1094 */
1095
1096 PERL_STATIC_INLINE bool
1097 S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
1098 {
1099     const U8 * first_variant;
1100
1101     PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1102
1103     if (len == 0) {
1104         len = strlen((const char *) s);
1105     }
1106
1107     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1108         if (el)
1109             *el = len;
1110
1111         if (ep) {
1112             *ep = s + len;
1113         }
1114
1115         return TRUE;
1116     }
1117
1118     {
1119         const U8* const send = s + len;
1120         const U8* x = first_variant;
1121         STRLEN outlen = first_variant - s;
1122
1123         while (x < send) {
1124             const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1125             if (UNLIKELY(! cur_len)) {
1126                 break;
1127             }
1128             x += cur_len;
1129             outlen++;
1130         }
1131
1132         if (el)
1133             *el = outlen;
1134
1135         if (ep) {
1136             *ep = x;
1137         }
1138
1139         return (x == send);
1140     }
1141 }
1142
1143 /*
1144
1145 =for apidoc is_utf8_string_loc_flags
1146
1147 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1148 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1149 "utf8ness success") in the C<ep> pointer.
1150
1151 See also C<L</is_utf8_string_loclen_flags>>.
1152
1153 =cut
1154 */
1155
1156 #define is_utf8_string_loc_flags(s, len, ep, flags)                         \
1157                         is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1158
1159
1160 /* The above 3 actual functions could have been moved into the more general one
1161  * just below, and made #defines that call it with the right 'flags'.  They are
1162  * currently kept separate to increase their chances of getting inlined */
1163
1164 /*
1165
1166 =for apidoc is_utf8_string_loclen_flags
1167
1168 Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1169 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1170 "utf8ness success") in the C<ep> pointer, and the number of UTF-8
1171 encoded characters in the C<el> pointer.
1172
1173 See also C<L</is_utf8_string_loc_flags>>.
1174
1175 =cut
1176 */
1177
1178 PERL_STATIC_INLINE bool
1179 S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
1180 {
1181     const U8 * first_variant;
1182
1183     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1184     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1185                           |UTF8_DISALLOW_PERL_EXTENDED)));
1186
1187     if (len == 0) {
1188         len = strlen((const char *) s);
1189     }
1190
1191     if (flags == 0) {
1192         return is_utf8_string_loclen(s, len, ep, el);
1193     }
1194
1195     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1196                                         == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1197     {
1198         return is_strict_utf8_string_loclen(s, len, ep, el);
1199     }
1200
1201     if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
1202                                     == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1203     {
1204         return is_c9strict_utf8_string_loclen(s, len, ep, el);
1205     }
1206
1207     if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1208         if (el)
1209             *el = len;
1210
1211         if (ep) {
1212             *ep = s + len;
1213         }
1214
1215         return TRUE;
1216     }
1217
1218     {
1219         const U8* send = s + len;
1220         const U8* x = first_variant;
1221         STRLEN outlen = first_variant - s;
1222
1223         while (x < send) {
1224             const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1225             if (UNLIKELY(! cur_len)) {
1226                 break;
1227             }
1228             x += cur_len;
1229             outlen++;
1230         }
1231
1232         if (el)
1233             *el = outlen;
1234
1235         if (ep) {
1236             *ep = x;
1237         }
1238
1239         return (x == send);
1240     }
1241 }
1242
1243 /*
1244 =for apidoc utf8_distance
1245
1246 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1247 and C<b>.
1248
1249 WARNING: use only if you *know* that the pointers point inside the
1250 same UTF-8 buffer.
1251
1252 =cut
1253 */
1254
1255 PERL_STATIC_INLINE IV
1256 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1257 {
1258     PERL_ARGS_ASSERT_UTF8_DISTANCE;
1259
1260     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1261 }
1262
1263 /*
1264 =for apidoc utf8_hop
1265
1266 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1267 forward or backward.
1268
1269 WARNING: do not use the following unless you *know* C<off> is within
1270 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1271 on the first byte of character or just after the last byte of a character.
1272
1273 =cut
1274 */
1275
1276 PERL_STATIC_INLINE U8 *
1277 Perl_utf8_hop(const U8 *s, SSize_t off)
1278 {
1279     PERL_ARGS_ASSERT_UTF8_HOP;
1280
1281     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1282      * the bitops (especially ~) can create illegal UTF-8.
1283      * In other words: in Perl UTF-8 is not just for Unicode. */
1284
1285     if (off >= 0) {
1286         while (off--)
1287             s += UTF8SKIP(s);
1288     }
1289     else {
1290         while (off++) {
1291             s--;
1292             while (UTF8_IS_CONTINUATION(*s))
1293                 s--;
1294         }
1295     }
1296     GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1297     return (U8 *)s;
1298     GCC_DIAG_RESTORE_STMT;
1299 }
1300
1301 /*
1302 =for apidoc utf8_hop_forward
1303
1304 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1305 forward.
1306
1307 C<off> must be non-negative.
1308
1309 C<s> must be before or equal to C<end>.
1310
1311 When moving forward it will not move beyond C<end>.
1312
1313 Will not exceed this limit even if the string is not valid "UTF-8".
1314
1315 =cut
1316 */
1317
1318 PERL_STATIC_INLINE U8 *
1319 Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1320 {
1321     PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1322
1323     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1324      * the bitops (especially ~) can create illegal UTF-8.
1325      * In other words: in Perl UTF-8 is not just for Unicode. */
1326
1327     assert(s <= end);
1328     assert(off >= 0);
1329
1330     while (off--) {
1331         STRLEN skip = UTF8SKIP(s);
1332         if ((STRLEN)(end - s) <= skip) {
1333             GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1334             return (U8 *)end;
1335             GCC_DIAG_RESTORE_STMT;
1336         }
1337         s += skip;
1338     }
1339
1340     GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1341     return (U8 *)s;
1342     GCC_DIAG_RESTORE_STMT;
1343 }
1344
1345 /*
1346 =for apidoc utf8_hop_back
1347
1348 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1349 backward.
1350
1351 C<off> must be non-positive.
1352
1353 C<s> must be after or equal to C<start>.
1354
1355 When moving backward it will not move before C<start>.
1356
1357 Will not exceed this limit even if the string is not valid "UTF-8".
1358
1359 =cut
1360 */
1361
1362 PERL_STATIC_INLINE U8 *
1363 Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1364 {
1365     PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1366
1367     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1368      * the bitops (especially ~) can create illegal UTF-8.
1369      * In other words: in Perl UTF-8 is not just for Unicode. */
1370
1371     assert(start <= s);
1372     assert(off <= 0);
1373
1374     while (off++ && s > start) {
1375         s--;
1376         while (UTF8_IS_CONTINUATION(*s) && s > start)
1377             s--;
1378     }
1379
1380     GCC_DIAG_IGNORE_STMT(-Wcast-qual);
1381     return (U8 *)s;
1382     GCC_DIAG_RESTORE_STMT;
1383 }
1384
1385 /*
1386 =for apidoc utf8_hop_safe
1387
1388 Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1389 either forward or backward.
1390
1391 When moving backward it will not move before C<start>.
1392
1393 When moving forward it will not move beyond C<end>.
1394
1395 Will not exceed those limits even if the string is not valid "UTF-8".
1396
1397 =cut
1398 */
1399
1400 PERL_STATIC_INLINE U8 *
1401 Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1402 {
1403     PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1404
1405     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1406      * the bitops (especially ~) can create illegal UTF-8.
1407      * In other words: in Perl UTF-8 is not just for Unicode. */
1408
1409     assert(start <= s && s <= end);
1410
1411     if (off >= 0) {
1412         return utf8_hop_forward(s, off, end);
1413     }
1414     else {
1415         return utf8_hop_back(s, off, start);
1416     }
1417 }
1418
1419 /*
1420
1421 =for apidoc is_utf8_valid_partial_char
1422
1423 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1424 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1425 points.  Otherwise, it returns 1 if there exists at least one non-empty
1426 sequence of bytes that when appended to sequence C<s>, starting at position
1427 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1428 otherwise returns 0.
1429
1430 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1431 point.
1432
1433 This is useful when a fixed-length buffer is being tested for being well-formed
1434 UTF-8, but the final few bytes in it don't comprise a full character; that is,
1435 it is split somewhere in the middle of the final code point's UTF-8
1436 representation.  (Presumably when the buffer is refreshed with the next chunk
1437 of data, the new first bytes will complete the partial code point.)   This
1438 function is used to verify that the final bytes in the current buffer are in
1439 fact the legal beginning of some code point, so that if they aren't, the
1440 failure can be signalled without having to wait for the next read.
1441
1442 =cut
1443 */
1444 #define is_utf8_valid_partial_char(s, e)                                    \
1445                                 is_utf8_valid_partial_char_flags(s, e, 0)
1446
1447 /*
1448
1449 =for apidoc is_utf8_valid_partial_char_flags
1450
1451 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1452 or not the input is a valid UTF-8 encoded partial character, but it takes an
1453 extra parameter, C<flags>, which can further restrict which code points are
1454 considered valid.
1455
1456 If C<flags> is 0, this behaves identically to
1457 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
1458 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
1459 there is any sequence of bytes that can complete the input partial character in
1460 such a way that a non-prohibited character is formed, the function returns
1461 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
1462 partial character input.  But many  of the other possible excluded types can be
1463 determined from just the first one or two bytes.
1464
1465 =cut
1466  */
1467
1468 PERL_STATIC_INLINE bool
1469 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
1470 {
1471     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
1472
1473     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
1474                           |UTF8_DISALLOW_PERL_EXTENDED)));
1475
1476     if (s >= e || s + UTF8SKIP(s) <= e) {
1477         return FALSE;
1478     }
1479
1480     return cBOOL(_is_utf8_char_helper(s, e, flags));
1481 }
1482
1483 /*
1484
1485 =for apidoc is_utf8_fixed_width_buf_flags
1486
1487 Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1488 is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1489 otherwise it returns FALSE.
1490
1491 If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1492 without restriction.  If the final few bytes of the buffer do not form a
1493 complete code point, this will return TRUE anyway, provided that
1494 C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1495
1496 If C<flags> in non-zero, it can be any combination of the
1497 C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1498 same meanings.
1499
1500 This function differs from C<L</is_utf8_string_flags>> only in that the latter
1501 returns FALSE if the final few bytes of the string don't form a complete code
1502 point.
1503
1504 =cut
1505  */
1506 #define is_utf8_fixed_width_buf_flags(s, len, flags)                        \
1507                 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1508
1509 /*
1510
1511 =for apidoc is_utf8_fixed_width_buf_loc_flags
1512
1513 Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1514 failure in the C<ep> pointer.  If the function returns TRUE, C<*ep> will point
1515 to the beginning of any partial character at the end of the buffer; if there is
1516 no partial character C<*ep> will contain C<s>+C<len>.
1517
1518 See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1519
1520 =cut
1521 */
1522
1523 #define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags)               \
1524                 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1525
1526 /*
1527
1528 =for apidoc is_utf8_fixed_width_buf_loclen_flags
1529
1530 Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1531 complete, valid characters found in the C<el> pointer.
1532
1533 =cut
1534 */
1535
1536 PERL_STATIC_INLINE bool
1537 S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
1538                                        STRLEN len,
1539                                        const U8 **ep,
1540                                        STRLEN *el,
1541                                        const U32 flags)
1542 {
1543     const U8 * maybe_partial;
1544
1545     PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1546
1547     if (! ep) {
1548         ep  = &maybe_partial;
1549     }
1550
1551     /* If it's entirely valid, return that; otherwise see if the only error is
1552      * that the final few bytes are for a partial character */
1553     return    is_utf8_string_loclen_flags(s, len, ep, el, flags)
1554            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1555 }
1556
1557 /* ------------------------------- perl.h ----------------------------- */
1558
1559 /*
1560 =head1 Miscellaneous Functions
1561
1562 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
1563
1564 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
1565 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
1566
1567 Return TRUE if the name is safe.
1568
1569 Used by the C<IS_SAFE_SYSCALL()> macro.
1570
1571 =cut
1572 */
1573
1574 PERL_STATIC_INLINE bool
1575 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
1576     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1577      * perl itself uses xce*() functions which accept 8-bit strings.
1578      */
1579
1580     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1581
1582     if (len > 1) {
1583         char *null_at;
1584         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
1585                 SETERRNO(ENOENT, LIB_INVARG);
1586                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
1587                                    "Invalid \\0 character in %s for %s: %s\\0%s",
1588                                    what, op_name, pv, null_at+1);
1589                 return FALSE;
1590         }
1591     }
1592
1593     return TRUE;
1594 }
1595
1596 /*
1597
1598 Return true if the supplied filename has a newline character
1599 immediately before the first (hopefully only) NUL.
1600
1601 My original look at this incorrectly used the len from SvPV(), but
1602 that's incorrect, since we allow for a NUL in pv[len-1].
1603
1604 So instead, strlen() and work from there.
1605
1606 This allow for the user reading a filename, forgetting to chomp it,
1607 then calling:
1608
1609   open my $foo, "$file\0";
1610
1611 */
1612
1613 #ifdef PERL_CORE
1614
1615 PERL_STATIC_INLINE bool
1616 S_should_warn_nl(const char *pv) {
1617     STRLEN len;
1618
1619     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1620
1621     len = strlen(pv);
1622
1623     return len > 0 && pv[len-1] == '\n';
1624 }
1625
1626 #endif
1627
1628 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1629
1630 #define MAX_CHARSET_NAME_LENGTH 2
1631
1632 PERL_STATIC_INLINE const char *
1633 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1634 {
1635     /* Returns a string that corresponds to the name of the regex character set
1636      * given by 'flags', and *lenp is set the length of that string, which
1637      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1638
1639     *lenp = 1;
1640     switch (get_regex_charset(flags)) {
1641         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1642         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
1643         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1644         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1645         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1646             *lenp = 2;
1647             return ASCII_MORE_RESTRICT_PAT_MODS;
1648     }
1649     /* The NOT_REACHED; hides an assert() which has a rather complex
1650      * definition in perl.h. */
1651     NOT_REACHED; /* NOTREACHED */
1652     return "?";     /* Unknown */
1653 }
1654
1655 /*
1656
1657 Return false if any get magic is on the SV other than taint magic.
1658
1659 */
1660
1661 PERL_STATIC_INLINE bool
1662 S_sv_only_taint_gmagic(SV *sv) {
1663     MAGIC *mg = SvMAGIC(sv);
1664
1665     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
1666
1667     while (mg) {
1668         if (mg->mg_type != PERL_MAGIC_taint
1669             && !(mg->mg_flags & MGf_GSKIP)
1670             && mg->mg_virtual->svt_get) {
1671             return FALSE;
1672         }
1673         mg = mg->mg_moremagic;
1674     }
1675
1676     return TRUE;
1677 }
1678
1679 /* ------------------ cop.h ------------------------------------------- */
1680
1681
1682 /* Enter a block. Push a new base context and return its address. */
1683
1684 PERL_STATIC_INLINE PERL_CONTEXT *
1685 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
1686 {
1687     PERL_CONTEXT * cx;
1688
1689     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
1690
1691     CXINC;
1692     cx = CX_CUR();
1693     cx->cx_type        = type;
1694     cx->blk_gimme      = gimme;
1695     cx->blk_oldsaveix  = saveix;
1696     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
1697     cx->blk_oldcop     = PL_curcop;
1698     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
1699     cx->blk_oldscopesp = PL_scopestack_ix;
1700     cx->blk_oldpm      = PL_curpm;
1701     cx->blk_old_tmpsfloor = PL_tmps_floor;
1702
1703     PL_tmps_floor        = PL_tmps_ix;
1704     CX_DEBUG(cx, "PUSH");
1705     return cx;
1706 }
1707
1708
1709 /* Exit a block (RETURN and LAST). */
1710
1711 PERL_STATIC_INLINE void
1712 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
1713 {
1714     PERL_ARGS_ASSERT_CX_POPBLOCK;
1715
1716     CX_DEBUG(cx, "POP");
1717     /* these 3 are common to cx_popblock and cx_topblock */
1718     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1719     PL_scopestack_ix = cx->blk_oldscopesp;
1720     PL_curpm         = cx->blk_oldpm;
1721
1722     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
1723      * and leaves a CX entry lying around for repeated use, so
1724      * skip for multicall */                  \
1725     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
1726             || PL_savestack_ix == cx->blk_oldsaveix);
1727     PL_curcop     = cx->blk_oldcop;
1728     PL_tmps_floor = cx->blk_old_tmpsfloor;
1729 }
1730
1731 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
1732  * Whereas cx_popblock() restores the state to the point just before
1733  * cx_pushblock() was called,  cx_topblock() restores it to the point just
1734  * *after* cx_pushblock() was called. */
1735
1736 PERL_STATIC_INLINE void
1737 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
1738 {
1739     PERL_ARGS_ASSERT_CX_TOPBLOCK;
1740
1741     CX_DEBUG(cx, "TOP");
1742     /* these 3 are common to cx_popblock and cx_topblock */
1743     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
1744     PL_scopestack_ix = cx->blk_oldscopesp;
1745     PL_curpm         = cx->blk_oldpm;
1746
1747     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
1748 }
1749
1750
1751 PERL_STATIC_INLINE void
1752 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
1753 {
1754     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
1755
1756     PERL_ARGS_ASSERT_CX_PUSHSUB;
1757
1758     PERL_DTRACE_PROBE_ENTRY(cv);
1759     cx->blk_sub.cv = cv;
1760     cx->blk_sub.olddepth = CvDEPTH(cv);
1761     cx->blk_sub.prevcomppad = PL_comppad;
1762     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
1763     cx->blk_sub.retop = retop;
1764     SvREFCNT_inc_simple_void_NN(cv);
1765     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
1766 }
1767
1768
1769 /* subsets of cx_popsub() */
1770
1771 PERL_STATIC_INLINE void
1772 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
1773 {
1774     CV *cv;
1775
1776     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
1777     assert(CxTYPE(cx) == CXt_SUB);
1778
1779     PL_comppad = cx->blk_sub.prevcomppad;
1780     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1781     cv = cx->blk_sub.cv;
1782     CvDEPTH(cv) = cx->blk_sub.olddepth;
1783     cx->blk_sub.cv = NULL;
1784     SvREFCNT_dec(cv);
1785 }
1786
1787
1788 /* handle the @_ part of leaving a sub */
1789
1790 PERL_STATIC_INLINE void
1791 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
1792 {
1793     AV *av;
1794
1795     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
1796     assert(CxTYPE(cx) == CXt_SUB);
1797     assert(AvARRAY(MUTABLE_AV(
1798         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
1799                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
1800
1801     CX_POP_SAVEARRAY(cx);
1802     av = MUTABLE_AV(PAD_SVl(0));
1803     if (UNLIKELY(AvREAL(av)))
1804         /* abandon @_ if it got reified */
1805         clear_defarray(av, 0);
1806     else {
1807         CLEAR_ARGARRAY(av);
1808     }
1809 }
1810
1811
1812 PERL_STATIC_INLINE void
1813 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
1814 {
1815     PERL_ARGS_ASSERT_CX_POPSUB;
1816     assert(CxTYPE(cx) == CXt_SUB);
1817
1818     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
1819
1820     if (CxHASARGS(cx))
1821         cx_popsub_args(cx);
1822     cx_popsub_common(cx);
1823 }
1824
1825
1826 PERL_STATIC_INLINE void
1827 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
1828 {
1829     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
1830
1831     cx->blk_format.cv          = cv;
1832     cx->blk_format.retop       = retop;
1833     cx->blk_format.gv          = gv;
1834     cx->blk_format.dfoutgv     = PL_defoutgv;
1835     cx->blk_format.prevcomppad = PL_comppad;
1836     cx->blk_u16                = 0;
1837
1838     SvREFCNT_inc_simple_void_NN(cv);
1839     CvDEPTH(cv)++;
1840     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
1841 }
1842
1843
1844 PERL_STATIC_INLINE void
1845 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
1846 {
1847     CV *cv;
1848     GV *dfout;
1849
1850     PERL_ARGS_ASSERT_CX_POPFORMAT;
1851     assert(CxTYPE(cx) == CXt_FORMAT);
1852
1853     dfout = cx->blk_format.dfoutgv;
1854     setdefout(dfout);
1855     cx->blk_format.dfoutgv = NULL;
1856     SvREFCNT_dec_NN(dfout);
1857
1858     PL_comppad = cx->blk_format.prevcomppad;
1859     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
1860     cv = cx->blk_format.cv;
1861     cx->blk_format.cv = NULL;
1862     --CvDEPTH(cv);
1863     SvREFCNT_dec_NN(cv);
1864 }
1865
1866
1867 PERL_STATIC_INLINE void
1868 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
1869 {
1870     PERL_ARGS_ASSERT_CX_PUSHEVAL;
1871
1872     cx->blk_eval.retop         = retop;
1873     cx->blk_eval.old_namesv    = namesv;
1874     cx->blk_eval.old_eval_root = PL_eval_root;
1875     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
1876     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
1877     cx->blk_eval.cur_top_env   = PL_top_env;
1878
1879     assert(!(PL_in_eval     & ~ 0x3F));
1880     assert(!(PL_op->op_type & ~0x1FF));
1881     cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
1882 }
1883
1884
1885 PERL_STATIC_INLINE void
1886 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
1887 {
1888     SV *sv;
1889
1890     PERL_ARGS_ASSERT_CX_POPEVAL;
1891     assert(CxTYPE(cx) == CXt_EVAL);
1892
1893     PL_in_eval = CxOLD_IN_EVAL(cx);
1894     assert(!(PL_in_eval & 0xc0));
1895     PL_eval_root = cx->blk_eval.old_eval_root;
1896     sv = cx->blk_eval.cur_text;
1897     if (sv && CxEVAL_TXT_REFCNTED(cx)) {
1898         cx->blk_eval.cur_text = NULL;
1899         SvREFCNT_dec_NN(sv);
1900     }
1901
1902     sv = cx->blk_eval.old_namesv;
1903     if (sv) {
1904         cx->blk_eval.old_namesv = NULL;
1905         SvREFCNT_dec_NN(sv);
1906     }
1907 }
1908
1909
1910 /* push a plain loop, i.e.
1911  *     { block }
1912  *     while (cond) { block }
1913  *     for (init;cond;continue) { block }
1914  * This loop can be last/redo'ed etc.
1915  */
1916
1917 PERL_STATIC_INLINE void
1918 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
1919 {
1920     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
1921     cx->blk_loop.my_op = cLOOP;
1922 }
1923
1924
1925 /* push a true for loop, i.e.
1926  *     for var (list) { block }
1927  */
1928
1929 PERL_STATIC_INLINE void
1930 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
1931 {
1932     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
1933
1934     /* this one line is common with cx_pushloop_plain */
1935     cx->blk_loop.my_op = cLOOP;
1936
1937     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
1938     cx->blk_loop.itersave      = itersave;
1939 #ifdef USE_ITHREADS
1940     cx->blk_loop.oldcomppad = PL_comppad;
1941 #endif
1942 }
1943
1944
1945 /* pop all loop types, including plain */
1946
1947 PERL_STATIC_INLINE void
1948 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
1949 {
1950     PERL_ARGS_ASSERT_CX_POPLOOP;
1951
1952     assert(CxTYPE_is_LOOP(cx));
1953     if (  CxTYPE(cx) == CXt_LOOP_ARY
1954        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
1955     {
1956         /* Free ary or cur. This assumes that state_u.ary.ary
1957          * aligns with state_u.lazysv.cur. See cx_dup() */
1958         SV *sv = cx->blk_loop.state_u.lazysv.cur;
1959         cx->blk_loop.state_u.lazysv.cur = NULL;
1960         SvREFCNT_dec_NN(sv);
1961         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1962             sv = cx->blk_loop.state_u.lazysv.end;
1963             cx->blk_loop.state_u.lazysv.end = NULL;
1964             SvREFCNT_dec_NN(sv);
1965         }
1966     }
1967     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
1968         SV *cursv;
1969         SV **svp = (cx)->blk_loop.itervar_u.svp;
1970         if ((cx->cx_type & CXp_FOR_GV))
1971             svp = &GvSV((GV*)svp);
1972         cursv = *svp;
1973         *svp = cx->blk_loop.itersave;
1974         cx->blk_loop.itersave = NULL;
1975         SvREFCNT_dec(cursv);
1976     }
1977 }
1978
1979
1980 PERL_STATIC_INLINE void
1981 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1982 {
1983     PERL_ARGS_ASSERT_CX_PUSHWHEN;
1984
1985     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1986 }
1987
1988
1989 PERL_STATIC_INLINE void
1990 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1991 {
1992     PERL_ARGS_ASSERT_CX_POPWHEN;
1993     assert(CxTYPE(cx) == CXt_WHEN);
1994
1995     PERL_UNUSED_ARG(cx);
1996     PERL_UNUSED_CONTEXT;
1997     /* currently NOOP */
1998 }
1999
2000
2001 PERL_STATIC_INLINE void
2002 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
2003 {
2004     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2005
2006     cx->blk_givwhen.leave_op = cLOGOP->op_other;
2007     cx->blk_givwhen.defsv_save = orig_defsv;
2008 }
2009
2010
2011 PERL_STATIC_INLINE void
2012 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
2013 {
2014     SV *sv;
2015
2016     PERL_ARGS_ASSERT_CX_POPGIVEN;
2017     assert(CxTYPE(cx) == CXt_GIVEN);
2018
2019     sv = GvSV(PL_defgv);
2020     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2021     cx->blk_givwhen.defsv_save = NULL;
2022     SvREFCNT_dec(sv);
2023 }
2024
2025 /* ------------------ util.h ------------------------------------------- */
2026
2027 /*
2028 =head1 Miscellaneous Functions
2029
2030 =for apidoc foldEQ
2031
2032 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2033 same
2034 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
2035 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
2036 range bytes match only themselves.
2037
2038 =cut
2039 */
2040
2041 PERL_STATIC_INLINE I32
2042 Perl_foldEQ(const char *s1, const char *s2, I32 len)
2043 {
2044     const U8 *a = (const U8 *)s1;
2045     const U8 *b = (const U8 *)s2;
2046
2047     PERL_ARGS_ASSERT_FOLDEQ;
2048
2049     assert(len >= 0);
2050
2051     while (len--) {
2052         if (*a != *b && *a != PL_fold[*b])
2053             return 0;
2054         a++,b++;
2055     }
2056     return 1;
2057 }
2058
2059 PERL_STATIC_INLINE I32
2060 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2061 {
2062     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
2063      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
2064      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
2065      * does it check that the strings each have at least 'len' characters */
2066
2067     const U8 *a = (const U8 *)s1;
2068     const U8 *b = (const U8 *)s2;
2069
2070     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2071
2072     assert(len >= 0);
2073
2074     while (len--) {
2075         if (*a != *b && *a != PL_fold_latin1[*b]) {
2076             return 0;
2077         }
2078         a++, b++;
2079     }
2080     return 1;
2081 }
2082
2083 /*
2084 =for apidoc foldEQ_locale
2085
2086 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2087 same case-insensitively in the current locale; false otherwise.
2088
2089 =cut
2090 */
2091
2092 PERL_STATIC_INLINE I32
2093 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2094 {
2095     dVAR;
2096     const U8 *a = (const U8 *)s1;
2097     const U8 *b = (const U8 *)s2;
2098
2099     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2100
2101     assert(len >= 0);
2102
2103     while (len--) {
2104         if (*a != *b && *a != PL_fold_locale[*b])
2105             return 0;
2106         a++,b++;
2107     }
2108     return 1;
2109 }
2110
2111 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2112
2113 PERL_STATIC_INLINE void *
2114 S_my_memrchr(const char * s, const char c, const STRLEN len)
2115 {
2116     /* memrchr(), since many platforms lack it */
2117
2118     const char * t = s + len - 1;
2119
2120     PERL_ARGS_ASSERT_MY_MEMRCHR;
2121
2122     while (t >= s) {
2123         if (*t == c) {
2124             return (void *) t;
2125         }
2126         t--;
2127     }
2128
2129     return NULL;
2130 }
2131
2132 #endif
2133
2134 /*
2135  * ex: set ts=8 sts=4 sw=4 et:
2136  */