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     assert(isREGEXP(re));
 157     return re->sv_u.svu_rx;
 158 }
 159
 160 /* ------------------------------- sv.h ------------------------------- */
 161
 162 PERL_STATIC_INLINE SV *
 163 S_SvREFCNT_inc(SV *sv)
 164 {
 165     if (LIKELY(sv != NULL))
 166         SvREFCNT(sv)++;
 167     return sv;
 168 }
 169 PERL_STATIC_INLINE SV *
 170 S_SvREFCNT_inc_NN(SV *sv)
 171 {
 172     SvREFCNT(sv)++;
 173     return sv;
 174 }
 175 PERL_STATIC_INLINE void
 176 S_SvREFCNT_inc_void(SV *sv)
 177 {
 178     if (LIKELY(sv != NULL))
 179         SvREFCNT(sv)++;
 180 }
 181 PERL_STATIC_INLINE void
 182 S_SvREFCNT_dec(pTHX_ SV *sv)
 183 {
 184     if (LIKELY(sv != NULL)) {
 185         U32 rc = SvREFCNT(sv);
 186         if (LIKELY(rc > 1))
 187             SvREFCNT(sv) = rc - 1;
 188         else
 189             Perl_sv_free2(aTHX_ sv, rc);
 190     }
 191 }
 192
 193 PERL_STATIC_INLINE void
 194 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
 195 {
 196     U32 rc = SvREFCNT(sv);
 197     if (LIKELY(rc > 1))
 198         SvREFCNT(sv) = rc - 1;
 199     else
 200         Perl_sv_free2(aTHX_ sv, rc);
 201 }
 202
 203 PERL_STATIC_INLINE void
 204 SvAMAGIC_on(SV *sv)
 205 {
 206     assert(SvROK(sv));
 207     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
 208 }
 209 PERL_STATIC_INLINE void
 210 SvAMAGIC_off(SV *sv)
 211 {
 212     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
 213         HvAMAGIC_off(SvSTASH(SvRV(sv)));
 214 }
 215
 216 PERL_STATIC_INLINE U32
 217 S_SvPADSTALE_on(SV *sv)
 218 {
 219     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 220     return SvFLAGS(sv) |= SVs_PADSTALE;
 221 }
 222 PERL_STATIC_INLINE U32
 223 S_SvPADSTALE_off(SV *sv)
 224 {
 225     assert(!(SvFLAGS(sv) & SVs_PADTMP));
 226     return SvFLAGS(sv) &= ~SVs_PADSTALE;
 227 }
 228 #if defined(PERL_CORE) || defined (PERL_EXT)
 229 PERL_STATIC_INLINE STRLEN
 230 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 231 {
 232     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
 233     if (SvGAMAGIC(sv)) {
 234         U8 *hopped = utf8_hop((U8 *)pv, pos);
 235         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
 236         return (STRLEN)(hopped - (U8 *)pv);
 237     }
 238     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
 239 }
 240 #endif
 241
 242 /* ------------------------------- handy.h ------------------------------- */
 243
 244 /* saves machine code for a common noreturn idiom typically used in Newx*() */
 245 #ifdef GCC_DIAG_PRAGMA
 246 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
 247 #endif
 248 static void
 249 S_croak_memory_wrap(void)
 250 {
 251     Perl_croak_nocontext("%s",PL_memory_wrap);
 252 }
 253 #ifdef GCC_DIAG_PRAGMA
 254 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
 255 #endif
 256
 257 /* ------------------------------- utf8.h ------------------------------- */
 258
 259 /*
 260 =head1 Unicode Support
 261 */
 262
 263 PERL_STATIC_INLINE void
 264 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
 265 {
 266     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
 267      * encoded string at '*dest', updating '*dest' to include it */
 268
 269     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
 270
 271     if (NATIVE_BYTE_IS_INVARIANT(byte))
 272         *((*dest)++) = byte;
 273     else {
 274         *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
 275         *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
 276     }
 277 }
 278
 279 /*
 280 =for apidoc valid_utf8_to_uvchr
 281 Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
 282 the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
 283 it passes C<L</isUTF8_CHAR>>.  Surrogates, non-character code points, and
 284 non-Unicode code points are allowed.
 285
 286 =cut
 287
 288  */
 289
 290 PERL_STATIC_INLINE UV
 291 Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
 292 {
 293     const UV expectlen = UTF8SKIP(s);
 294     const U8* send = s + expectlen;
 295     UV uv = *s;
 296
 297     PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
 298
 299     if (retlen) {
 300         *retlen = expectlen;
 301     }
 302
 303     /* An invariant is trivially returned */
 304     if (expectlen == 1) {
 305         return uv;
 306     }
 307
 308     /* Remove the leading bits that indicate the number of bytes, leaving just
 309      * the bits that are part of the value */
 310     uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
 311
 312     /* Now, loop through the remaining bytes, accumulating each into the
 313      * working total as we go.  (I khw tried unrolling the loop for up to 4
 314      * bytes, but there was no performance improvement) */
 315     for (++s; s < send; s++) {
 316         uv = UTF8_ACCUMULATE(uv, *s);
 317     }
 318
 319     return UNI_TO_NATIVE(uv);
 320
 321 }
 322
 323 /*
 324 =for apidoc is_utf8_invariant_string
 325
 326 Returns TRUE if the first C<len> bytes of the string C<s> are the same
 327 regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
 328 EBCDIC machines); otherwise it returns FALSE.  That is, it returns TRUE if they
 329 are UTF-8 invariant.  On ASCII-ish machines, all the ASCII characters and only
 330 the ASCII characters fit this definition.  On EBCDIC machines, the ASCII-range
 331 characters are invariant, but so also are the C1 controls.
 332
 333 If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
 334 use this option, that C<s> can't have embedded C<NUL> characters and has to
 335 have a terminating C<NUL> byte).
 336
 337 See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
 338 L</is_utf8_string_loc>().
 339
 340 =cut
 341 */
 342
 343 PERL_STATIC_INLINE bool
 344 S_is_utf8_invariant_string(const U8* const s, const STRLEN len)
 345 {
 346     const U8* const send = s + (len ? len : strlen((const char *)s));
 347     const U8* x = s;
 348
 349     PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING;
 350
 351     for (; x < send; ++x) {
 352         if (!UTF8_IS_INVARIANT(*x))
 353             return FALSE;
 354     }
 355
 356     return TRUE;
 357 }
 358
 359 /*
 360 =for apidoc is_utf8_string
 361
 362 Returns TRUE if the first C<len> bytes of string C<s> form a valid
 363 Perl-extended-UTF-8 string; returns FALSE otherwise.  If C<len> is 0, it will
 364 be calculated using C<strlen(s)> (which means if you use this option, that C<s>
 365 can't have embedded C<NUL> characters and has to have a terminating C<NUL>
 366 byte).  Note that all characters being ASCII constitute 'a valid UTF-8 string'.
 367
 368 Code points above Unicode, surrogates, and non-character code points are
 369 considered valid by this function.
 370
 371 See also L</is_utf8_invariant_string>(), L</is_utf8_string_loclen>(), and
 372 L</is_utf8_string_loc>().
 373
 374 =cut
 375 */
 376
 377 PERL_STATIC_INLINE bool
 378 Perl_is_utf8_string(const U8 *s, const STRLEN len)
 379 {
 380     /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
 381      * Be aware of possible changes to that */
 382
 383     const U8* const send = s + (len ? len : strlen((const char *)s));
 384     const U8* x = s;
 385
 386     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 387
 388     while (x < send) {
 389         const STRLEN cur_len = isUTF8_CHAR(x, send);
 390         if (UNLIKELY(! cur_len)) {
 391             return FALSE;
 392         }
 393         x += cur_len;
 394     }
 395
 396     return TRUE;
 397 }
 398
 399 /*
 400 Implemented as a macro in utf8.h
 401
 402 =for apidoc is_utf8_string_loc
 403
 404 Like L</is_utf8_string> but stores the location of the failure (in the
 405 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 406 "utf8ness success") in the C<ep> pointer.
 407
 408 See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
 409
 410 =for apidoc is_utf8_string_loclen
 411
 412 Like L</is_utf8_string>() but stores the location of the failure (in the
 413 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 414 "utf8ness success") in the C<ep>, and the number of UTF-8
 415 encoded characters in the C<el> pointer.
 416
 417 See also L</is_utf8_string_loc>() and L</is_utf8_string>().
 418
 419 =cut
 420 */
 421
 422 PERL_STATIC_INLINE bool
 423 Perl_is_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
 424 {
 425     const U8* const send = s + (len ? len : strlen((const char *)s));
 426     const U8* x = s;
 427     STRLEN outlen = 0;
 428
 429     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 430
 431     while (x < send) {
 432         const STRLEN cur_len = isUTF8_CHAR(x, send);
 433         if (UNLIKELY(! cur_len)) {
 434             break;
 435         }
 436         x += cur_len;
 437         outlen++;
 438     }
 439
 440     if (el)
 441         *el = outlen;
 442
 443     if (ep) {
 444         *ep = x;
 445     }
 446
 447     return (x == send);
 448 }
 449
 450 /*
 451 =for apidoc utf8_distance
 452
 453 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
 454 and C<b>.
 455
 456 WARNING: use only if you *know* that the pointers point inside the
 457 same UTF-8 buffer.
 458
 459 =cut
 460 */
 461
 462 PERL_STATIC_INLINE IV
 463 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
 464 {
 465     PERL_ARGS_ASSERT_UTF8_DISTANCE;
 466
 467     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
 468 }
 469
 470 /*
 471 =for apidoc utf8_hop
 472
 473 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 474 forward or backward.
 475
 476 WARNING: do not use the following unless you *know* C<off> is within
 477 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 478 on the first byte of character or just after the last byte of a character.
 479
 480 =cut
 481 */
 482
 483 PERL_STATIC_INLINE U8 *
 484 Perl_utf8_hop(const U8 *s, SSize_t off)
 485 {
 486     PERL_ARGS_ASSERT_UTF8_HOP;
 487
 488     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 489      * the bitops (especially ~) can create illegal UTF-8.
 490      * In other words: in Perl UTF-8 is not just for Unicode. */
 491
 492     if (off >= 0) {
 493         while (off--)
 494             s += UTF8SKIP(s);
 495     }
 496     else {
 497         while (off++) {
 498             s--;
 499             while (UTF8_IS_CONTINUATION(*s))
 500                 s--;
 501         }
 502     }
 503     return (U8 *)s;
 504 }
 505
 506 /*
 507
 508 =for apidoc is_utf8_valid_partial_char
 509
 510 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
 511 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
 512 points.  Otherwise, it returns 1 if there exists at least one non-empty
 513 sequence of bytes that when appended to sequence C<s>, starting at position
 514 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
 515 otherwise returns 0.
 516
 517 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
 518 point.
 519
 520 This is useful when a fixed-length buffer is being tested for being well-formed
 521 UTF-8, but the final few bytes in it don't comprise a full character; that is,
 522 it is split somewhere in the middle of the final code point's UTF-8
 523 representation.  (Presumably when the buffer is refreshed with the next chunk
 524 of data, the new first bytes will complete the partial code point.)   This
 525 function is used to verify that the final bytes in the current buffer are in
 526 fact the legal beginning of some code point, so that if they aren't, the
 527 failure can be signalled without having to wait for the next read.
 528
 529 =cut
 530 */
 531 #define is_utf8_valid_partial_char(s, e) is_utf8_valid_partial_char_flags(s, e, 0)
 532
 533 /*
 534
 535 =for apidoc is_utf8_valid_partial_char_flags
 536
 537 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
 538 or not the input is a valid UTF-8 encoded partial character, but it takes an
 539 extra parameter, C<flags>, which can further restrict which code points are
 540 considered valid.
 541
 542 If C<flags> is 0, this behaves identically to
 543 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
 544 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
 545 there is any sequence of bytes that can complete the input partial character in
 546 such a way that a non-prohibited character is formed, the function returns
 547 TRUE; otherwise FALSE.  Non characters cannot be determined based on partial
 548 character input.  But many  of the other possible excluded types can be
 549 determined from just the first one or two bytes.
 550
 551 =cut
 552  */
 553
 554 PERL_STATIC_INLINE bool
 555 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
 556 {
 557     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
 558
 559     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
 560                           |UTF8_DISALLOW_ABOVE_31_BIT)));
 561
 562     if (s >= e || s + UTF8SKIP(s) <= e) {
 563         return FALSE;
 564     }
 565
 566     return cBOOL(_is_utf8_char_helper(s, e, flags));
 567 }
 568
 569 /* ------------------------------- perl.h ----------------------------- */
 570
 571 /*
 572 =head1 Miscellaneous Functions
 573
 574 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
 575
 576 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
 577 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
 578
 579 Return TRUE if the name is safe.
 580
 581 Used by the C<IS_SAFE_SYSCALL()> macro.
 582
 583 =cut
 584 */
 585
 586 PERL_STATIC_INLINE bool
 587 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
 588     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
 589      * perl itself uses xce*() functions which accept 8-bit strings.
 590      */
 591
 592     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
 593
 594     if (len > 1) {
 595         char *null_at;
 596         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
 597                 SETERRNO(ENOENT, LIB_INVARG);
 598                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
 599                                    "Invalid \\0 character in %s for %s: %s\\0%s",
 600                                    what, op_name, pv, null_at+1);
 601                 return FALSE;
 602         }
 603     }
 604
 605     return TRUE;
 606 }
 607
 608 /*
 609
 610 Return true if the supplied filename has a newline character
 611 immediately before the first (hopefully only) NUL.
 612
 613 My original look at this incorrectly used the len from SvPV(), but
 614 that's incorrect, since we allow for a NUL in pv[len-1].
 615
 616 So instead, strlen() and work from there.
 617
 618 This allow for the user reading a filename, forgetting to chomp it,
 619 then calling:
 620
 621   open my $foo, "$file\0";
 622
 623 */
 624
 625 #ifdef PERL_CORE
 626
 627 PERL_STATIC_INLINE bool
 628 S_should_warn_nl(const char *pv) {
 629     STRLEN len;
 630
 631     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
 632
 633     len = strlen(pv);
 634
 635     return len > 0 && pv[len-1] == '\n';
 636 }
 637
 638 #endif
 639
 640 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
 641
 642 #define MAX_CHARSET_NAME_LENGTH 2
 643
 644 PERL_STATIC_INLINE const char *
 645 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 646 {
 647     /* Returns a string that corresponds to the name of the regex character set
 648      * given by 'flags', and *lenp is set the length of that string, which
 649      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
 650
 651     *lenp = 1;
 652     switch (get_regex_charset(flags)) {
 653         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
 654         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
 655         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
 656         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
 657         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
 658             *lenp = 2;
 659             return ASCII_MORE_RESTRICT_PAT_MODS;
 660     }
 661     /* The NOT_REACHED; hides an assert() which has a rather complex
 662      * definition in perl.h. */
 663     NOT_REACHED; /* NOTREACHED */
 664     return "?";     /* Unknown */
 665 }
 666
 667 /*
 668
 669 Return false if any get magic is on the SV other than taint magic.
 670
 671 */
 672
 673 PERL_STATIC_INLINE bool
 674 S_sv_only_taint_gmagic(SV *sv) {
 675     MAGIC *mg = SvMAGIC(sv);
 676
 677     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
 678
 679     while (mg) {
 680         if (mg->mg_type != PERL_MAGIC_taint
 681             && !(mg->mg_flags & MGf_GSKIP)
 682             && mg->mg_virtual->svt_get) {
 683             return FALSE;
 684         }
 685         mg = mg->mg_moremagic;
 686     }
 687
 688     return TRUE;
 689 }
 690
 691 /* ------------------ cop.h ------------------------------------------- */
 692
 693
 694 /* Enter a block. Push a new base context and return its address. */
 695
 696 PERL_STATIC_INLINE PERL_CONTEXT *
 697 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
 698 {
 699     PERL_CONTEXT * cx;
 700
 701     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
 702
 703     CXINC;
 704     cx = CX_CUR();
 705     cx->cx_type        = type;
 706     cx->blk_gimme      = gimme;
 707     cx->blk_oldsaveix  = saveix;
 708     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
 709     cx->blk_oldcop     = PL_curcop;
 710     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
 711     cx->blk_oldscopesp = PL_scopestack_ix;
 712     cx->blk_oldpm      = PL_curpm;
 713     cx->blk_old_tmpsfloor = PL_tmps_floor;
 714
 715     PL_tmps_floor        = PL_tmps_ix;
 716     CX_DEBUG(cx, "PUSH");
 717     return cx;
 718 }
 719
 720
 721 /* Exit a block (RETURN and LAST). */
 722
 723 PERL_STATIC_INLINE void
 724 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
 725 {
 726     PERL_ARGS_ASSERT_CX_POPBLOCK;
 727
 728     CX_DEBUG(cx, "POP");
 729     /* these 3 are common to cx_popblock and cx_topblock */
 730     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
 731     PL_scopestack_ix = cx->blk_oldscopesp;
 732     PL_curpm         = cx->blk_oldpm;
 733
 734     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
 735      * and leaves a CX entry lying around for repeated use, so
 736      * skip for multicall */                  \
 737     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
 738             || PL_savestack_ix == cx->blk_oldsaveix);
 739     PL_curcop     = cx->blk_oldcop;
 740     PL_tmps_floor = cx->blk_old_tmpsfloor;
 741 }
 742
 743 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
 744  * Whereas cx_popblock() restores the state to the point just before
 745  * cx_pushblock() was called,  cx_topblock() restores it to the point just
 746  * *after* cx_pushblock() was called. */
 747
 748 PERL_STATIC_INLINE void
 749 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
 750 {
 751     PERL_ARGS_ASSERT_CX_TOPBLOCK;
 752
 753     CX_DEBUG(cx, "TOP");
 754     /* these 3 are common to cx_popblock and cx_topblock */
 755     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
 756     PL_scopestack_ix = cx->blk_oldscopesp;
 757     PL_curpm         = cx->blk_oldpm;
 758
 759     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
 760 }
 761
 762
 763 PERL_STATIC_INLINE void
 764 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
 765 {
 766     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
 767
 768     PERL_ARGS_ASSERT_CX_PUSHSUB;
 769
 770     PERL_DTRACE_PROBE_ENTRY(cv);
 771     cx->blk_sub.cv = cv;
 772     cx->blk_sub.olddepth = CvDEPTH(cv);
 773     cx->blk_sub.prevcomppad = PL_comppad;
 774     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
 775     cx->blk_sub.retop = retop;
 776     SvREFCNT_inc_simple_void_NN(cv);
 777     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
 778 }
 779
 780
 781 /* subsets of cx_popsub() */
 782
 783 PERL_STATIC_INLINE void
 784 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
 785 {
 786     CV *cv;
 787
 788     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
 789     assert(CxTYPE(cx) == CXt_SUB);
 790
 791     PL_comppad = cx->blk_sub.prevcomppad;
 792     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
 793     cv = cx->blk_sub.cv;
 794     CvDEPTH(cv) = cx->blk_sub.olddepth;
 795     cx->blk_sub.cv = NULL;
 796     SvREFCNT_dec(cv);
 797 }
 798
 799
 800 /* handle the @_ part of leaving a sub */
 801
 802 PERL_STATIC_INLINE void
 803 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
 804 {
 805     AV *av;
 806
 807     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
 808     assert(CxTYPE(cx) == CXt_SUB);
 809     assert(AvARRAY(MUTABLE_AV(
 810         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
 811                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
 812
 813     CX_POP_SAVEARRAY(cx);
 814     av = MUTABLE_AV(PAD_SVl(0));
 815     if (UNLIKELY(AvREAL(av)))
 816         /* abandon @_ if it got reified */
 817         clear_defarray(av, 0);
 818     else {
 819         CLEAR_ARGARRAY(av);
 820     }
 821 }
 822
 823
 824 PERL_STATIC_INLINE void
 825 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
 826 {
 827     PERL_ARGS_ASSERT_CX_POPSUB;
 828     assert(CxTYPE(cx) == CXt_SUB);
 829
 830     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
 831
 832     if (CxHASARGS(cx))
 833         cx_popsub_args(cx);
 834     cx_popsub_common(cx);
 835 }
 836
 837
 838 PERL_STATIC_INLINE void
 839 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
 840 {
 841     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
 842
 843     cx->blk_format.cv          = cv;
 844     cx->blk_format.retop       = retop;
 845     cx->blk_format.gv          = gv;
 846     cx->blk_format.dfoutgv     = PL_defoutgv;
 847     cx->blk_format.prevcomppad = PL_comppad;
 848     cx->blk_u16                = 0;
 849
 850     SvREFCNT_inc_simple_void_NN(cv);
 851     CvDEPTH(cv)++;
 852     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
 853 }
 854
 855
 856 PERL_STATIC_INLINE void
 857 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
 858 {
 859     CV *cv;
 860     GV *dfout;
 861
 862     PERL_ARGS_ASSERT_CX_POPFORMAT;
 863     assert(CxTYPE(cx) == CXt_FORMAT);
 864
 865     dfout = cx->blk_format.dfoutgv;
 866     setdefout(dfout);
 867     cx->blk_format.dfoutgv = NULL;
 868     SvREFCNT_dec_NN(dfout);
 869
 870     PL_comppad = cx->blk_format.prevcomppad;
 871     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
 872     cv = cx->blk_format.cv;
 873     cx->blk_format.cv = NULL;
 874     --CvDEPTH(cv);
 875     SvREFCNT_dec_NN(cv);
 876 }
 877
 878
 879 PERL_STATIC_INLINE void
 880 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
 881 {
 882     PERL_ARGS_ASSERT_CX_PUSHEVAL;
 883
 884     cx->blk_eval.retop         = retop;
 885     cx->blk_eval.old_namesv    = namesv;
 886     cx->blk_eval.old_eval_root = PL_eval_root;
 887     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
 888     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
 889     cx->blk_eval.cur_top_env   = PL_top_env;
 890
 891     assert(!(PL_in_eval     & ~ 0x7F));
 892     assert(!(PL_op->op_type & ~0x1FF));
 893     cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
 894 }
 895
 896
 897 PERL_STATIC_INLINE void
 898 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
 899 {
 900     SV *sv;
 901
 902     PERL_ARGS_ASSERT_CX_POPEVAL;
 903     assert(CxTYPE(cx) == CXt_EVAL);
 904
 905     PL_in_eval = CxOLD_IN_EVAL(cx);
 906     PL_eval_root = cx->blk_eval.old_eval_root;
 907     sv = cx->blk_eval.cur_text;
 908     if (sv && SvSCREAM(sv)) {
 909         cx->blk_eval.cur_text = NULL;
 910         SvREFCNT_dec_NN(sv);
 911     }
 912
 913     sv = cx->blk_eval.old_namesv;
 914     if (sv) {
 915         cx->blk_eval.old_namesv = NULL;
 916         SvREFCNT_dec_NN(sv);
 917     }
 918 }
 919
 920
 921 /* push a plain loop, i.e.
 922  *     { block }
 923  *     while (cond) { block }
 924  *     for (init;cond;continue) { block }
 925  * This loop can be last/redo'ed etc.
 926  */
 927
 928 PERL_STATIC_INLINE void
 929 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
 930 {
 931     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
 932     cx->blk_loop.my_op = cLOOP;
 933 }
 934
 935
 936 /* push a true for loop, i.e.
 937  *     for var (list) { block }
 938  */
 939
 940 PERL_STATIC_INLINE void
 941 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
 942 {
 943     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
 944
 945     /* this one line is common with cx_pushloop_plain */
 946     cx->blk_loop.my_op = cLOOP;
 947
 948     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
 949     cx->blk_loop.itersave      = itersave;
 950 #ifdef USE_ITHREADS
 951     cx->blk_loop.oldcomppad = PL_comppad;
 952 #endif
 953 }
 954
 955
 956 /* pop all loop types, including plain */
 957
 958 PERL_STATIC_INLINE void
 959 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
 960 {
 961     PERL_ARGS_ASSERT_CX_POPLOOP;
 962
 963     assert(CxTYPE_is_LOOP(cx));
 964     if (  CxTYPE(cx) == CXt_LOOP_ARY
 965        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
 966     {
 967         /* Free ary or cur. This assumes that state_u.ary.ary
 968          * aligns with state_u.lazysv.cur. See cx_dup() */
 969         SV *sv = cx->blk_loop.state_u.lazysv.cur;
 970         cx->blk_loop.state_u.lazysv.cur = NULL;
 971         SvREFCNT_dec_NN(sv);
 972         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
 973             sv = cx->blk_loop.state_u.lazysv.end;
 974             cx->blk_loop.state_u.lazysv.end = NULL;
 975             SvREFCNT_dec_NN(sv);
 976         }
 977     }
 978     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
 979         SV *cursv;
 980         SV **svp = (cx)->blk_loop.itervar_u.svp;
 981         if ((cx->cx_type & CXp_FOR_GV))
 982             svp = &GvSV((GV*)svp);
 983         cursv = *svp;
 984         *svp = cx->blk_loop.itersave;
 985         cx->blk_loop.itersave = NULL;
 986         SvREFCNT_dec(cursv);
 987     }
 988 }
 989
 990
 991 PERL_STATIC_INLINE void
 992 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
 993 {
 994     PERL_ARGS_ASSERT_CX_PUSHWHEN;
 995
 996     cx->blk_givwhen.leave_op = cLOGOP->op_other;
 997 }
 998
 999
1000 PERL_STATIC_INLINE void
1001 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1002 {
1003     PERL_ARGS_ASSERT_CX_POPWHEN;
1004     assert(CxTYPE(cx) == CXt_WHEN);
1005
1006     PERL_UNUSED_ARG(cx);
1007     PERL_UNUSED_CONTEXT;
1008     /* currently NOOP */
1009 }
1010
1011
1012 PERL_STATIC_INLINE void
1013 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1014 {
1015     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1016
1017     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1018     cx->blk_givwhen.defsv_save = orig_defsv;
1019 }
1020
1021
1022 PERL_STATIC_INLINE void
1023 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1024 {
1025     SV *sv;
1026
1027     PERL_ARGS_ASSERT_CX_POPGIVEN;
1028     assert(CxTYPE(cx) == CXt_GIVEN);
1029
1030     sv = GvSV(PL_defgv);
1031     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1032     cx->blk_givwhen.defsv_save = NULL;
1033     SvREFCNT_dec(sv);
1034 }
1035
1036 /*
1037  * ex: set ts=8 sts=4 sw=4 et:
1038  */