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 C<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 This function considers Perl's extended UTF-8 to be valid.  That means that
 369 code points above Unicode, surrogates, and non-character code points are
 370 considered valid by this function.
 371
 372 See also L</is_utf8_invariant_string>(), L</is_utf8_string_loclen>(), and
 373 L</is_utf8_string_loc>().
 374
 375 =cut
 376 */
 377
 378 PERL_STATIC_INLINE bool
 379 Perl_is_utf8_string(const U8 *s, const STRLEN len)
 380 {
 381     /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
 382      * Be aware of possible changes to that */
 383
 384     const U8* const send = s + (len ? len : strlen((const char *)s));
 385     const U8* x = s;
 386
 387     PERL_ARGS_ASSERT_IS_UTF8_STRING;
 388
 389     while (x < send) {
 390         const STRLEN cur_len = isUTF8_CHAR(x, send);
 391         if (UNLIKELY(! cur_len)) {
 392             return FALSE;
 393         }
 394         x += cur_len;
 395     }
 396
 397     return TRUE;
 398 }
 399
 400 /*
 401
 402 =for apidoc is_utf8_string_loc
 403
 404 Like C<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 C<L</is_utf8_string_loclen>>.
 409
 410 =cut
 411 */
 412
 413 #define is_utf8_string_loc(s, len, ep)  is_utf8_string_loclen(s, len, ep, 0)
 414
 415 /*
 416
 417 =for apidoc is_utf8_string_loclen
 418
 419 Like C<L</is_utf8_string>> but stores the location of the failure (in the
 420 case of "utf8ness failure") or the location C<s>+C<len> (in the case of
 421 "utf8ness success") in the C<ep>, and the number of UTF-8
 422 encoded characters in the C<el> pointer.
 423
 424 See also C<L</is_utf8_string_loc>>.
 425
 426 =cut
 427 */
 428
 429 PERL_STATIC_INLINE bool
 430 Perl_is_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
 431 {
 432     const U8* const send = s + (len ? len : strlen((const char *)s));
 433     const U8* x = s;
 434     STRLEN outlen = 0;
 435
 436     PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
 437
 438     while (x < send) {
 439         const STRLEN cur_len = isUTF8_CHAR(x, send);
 440         if (UNLIKELY(! cur_len)) {
 441             break;
 442         }
 443         x += cur_len;
 444         outlen++;
 445     }
 446
 447     if (el)
 448         *el = outlen;
 449
 450     if (ep) {
 451         *ep = x;
 452     }
 453
 454     return (x == send);
 455 }
 456
 457 /*
 458 =for apidoc utf8_distance
 459
 460 Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
 461 and C<b>.
 462
 463 WARNING: use only if you *know* that the pointers point inside the
 464 same UTF-8 buffer.
 465
 466 =cut
 467 */
 468
 469 PERL_STATIC_INLINE IV
 470 Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
 471 {
 472     PERL_ARGS_ASSERT_UTF8_DISTANCE;
 473
 474     return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
 475 }
 476
 477 /*
 478 =for apidoc utf8_hop
 479
 480 Return the UTF-8 pointer C<s> displaced by C<off> characters, either
 481 forward or backward.
 482
 483 WARNING: do not use the following unless you *know* C<off> is within
 484 the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
 485 on the first byte of character or just after the last byte of a character.
 486
 487 =cut
 488 */
 489
 490 PERL_STATIC_INLINE U8 *
 491 Perl_utf8_hop(const U8 *s, SSize_t off)
 492 {
 493     PERL_ARGS_ASSERT_UTF8_HOP;
 494
 495     /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
 496      * the bitops (especially ~) can create illegal UTF-8.
 497      * In other words: in Perl UTF-8 is not just for Unicode. */
 498
 499     if (off >= 0) {
 500         while (off--)
 501             s += UTF8SKIP(s);
 502     }
 503     else {
 504         while (off++) {
 505             s--;
 506             while (UTF8_IS_CONTINUATION(*s))
 507                 s--;
 508         }
 509     }
 510     return (U8 *)s;
 511 }
 512
 513 /*
 514
 515 =for apidoc is_utf8_valid_partial_char
 516
 517 Returns 0 if the sequence of bytes starting at C<s> and looking no further than
 518 S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
 519 points.  Otherwise, it returns 1 if there exists at least one non-empty
 520 sequence of bytes that when appended to sequence C<s>, starting at position
 521 C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
 522 otherwise returns 0.
 523
 524 In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
 525 point.
 526
 527 This is useful when a fixed-length buffer is being tested for being well-formed
 528 UTF-8, but the final few bytes in it don't comprise a full character; that is,
 529 it is split somewhere in the middle of the final code point's UTF-8
 530 representation.  (Presumably when the buffer is refreshed with the next chunk
 531 of data, the new first bytes will complete the partial code point.)   This
 532 function is used to verify that the final bytes in the current buffer are in
 533 fact the legal beginning of some code point, so that if they aren't, the
 534 failure can be signalled without having to wait for the next read.
 535
 536 =cut
 537 */
 538 #define is_utf8_valid_partial_char(s, e)                                    \
 539                                 is_utf8_valid_partial_char_flags(s, e, 0)
 540
 541 /*
 542
 543 =for apidoc is_utf8_valid_partial_char_flags
 544
 545 Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
 546 or not the input is a valid UTF-8 encoded partial character, but it takes an
 547 extra parameter, C<flags>, which can further restrict which code points are
 548 considered valid.
 549
 550 If C<flags> is 0, this behaves identically to
 551 C<L</is_utf8_valid_partial_char>>.  Otherwise C<flags> can be any combination
 552 of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>.  If
 553 there is any sequence of bytes that can complete the input partial character in
 554 such a way that a non-prohibited character is formed, the function returns
 555 TRUE; otherwise FALSE.  Non character code points cannot be determined based on
 556 partial character input.  But many  of the other possible excluded types can be
 557 determined from just the first one or two bytes.
 558
 559 =cut
 560  */
 561
 562 PERL_STATIC_INLINE bool
 563 S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
 564 {
 565     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
 566
 567     assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
 568                           |UTF8_DISALLOW_ABOVE_31_BIT)));
 569
 570     if (s >= e || s + UTF8SKIP(s) <= e) {
 571         return FALSE;
 572     }
 573
 574     return cBOOL(_is_utf8_char_helper(s, e, flags));
 575 }
 576
 577 /* ------------------------------- perl.h ----------------------------- */
 578
 579 /*
 580 =head1 Miscellaneous Functions
 581
 582 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
 583
 584 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
 585 If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
 586
 587 Return TRUE if the name is safe.
 588
 589 Used by the C<IS_SAFE_SYSCALL()> macro.
 590
 591 =cut
 592 */
 593
 594 PERL_STATIC_INLINE bool
 595 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
 596     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
 597      * perl itself uses xce*() functions which accept 8-bit strings.
 598      */
 599
 600     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
 601
 602     if (len > 1) {
 603         char *null_at;
 604         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
 605                 SETERRNO(ENOENT, LIB_INVARG);
 606                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
 607                                    "Invalid \\0 character in %s for %s: %s\\0%s",
 608                                    what, op_name, pv, null_at+1);
 609                 return FALSE;
 610         }
 611     }
 612
 613     return TRUE;
 614 }
 615
 616 /*
 617
 618 Return true if the supplied filename has a newline character
 619 immediately before the first (hopefully only) NUL.
 620
 621 My original look at this incorrectly used the len from SvPV(), but
 622 that's incorrect, since we allow for a NUL in pv[len-1].
 623
 624 So instead, strlen() and work from there.
 625
 626 This allow for the user reading a filename, forgetting to chomp it,
 627 then calling:
 628
 629   open my $foo, "$file\0";
 630
 631 */
 632
 633 #ifdef PERL_CORE
 634
 635 PERL_STATIC_INLINE bool
 636 S_should_warn_nl(const char *pv) {
 637     STRLEN len;
 638
 639     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
 640
 641     len = strlen(pv);
 642
 643     return len > 0 && pv[len-1] == '\n';
 644 }
 645
 646 #endif
 647
 648 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
 649
 650 #define MAX_CHARSET_NAME_LENGTH 2
 651
 652 PERL_STATIC_INLINE const char *
 653 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 654 {
 655     /* Returns a string that corresponds to the name of the regex character set
 656      * given by 'flags', and *lenp is set the length of that string, which
 657      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
 658
 659     *lenp = 1;
 660     switch (get_regex_charset(flags)) {
 661         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
 662         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
 663         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
 664         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
 665         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
 666             *lenp = 2;
 667             return ASCII_MORE_RESTRICT_PAT_MODS;
 668     }
 669     /* The NOT_REACHED; hides an assert() which has a rather complex
 670      * definition in perl.h. */
 671     NOT_REACHED; /* NOTREACHED */
 672     return "?";     /* Unknown */
 673 }
 674
 675 /*
 676
 677 Return false if any get magic is on the SV other than taint magic.
 678
 679 */
 680
 681 PERL_STATIC_INLINE bool
 682 S_sv_only_taint_gmagic(SV *sv) {
 683     MAGIC *mg = SvMAGIC(sv);
 684
 685     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
 686
 687     while (mg) {
 688         if (mg->mg_type != PERL_MAGIC_taint
 689             && !(mg->mg_flags & MGf_GSKIP)
 690             && mg->mg_virtual->svt_get) {
 691             return FALSE;
 692         }
 693         mg = mg->mg_moremagic;
 694     }
 695
 696     return TRUE;
 697 }
 698
 699 /* ------------------ cop.h ------------------------------------------- */
 700
 701
 702 /* Enter a block. Push a new base context and return its address. */
 703
 704 PERL_STATIC_INLINE PERL_CONTEXT *
 705 S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
 706 {
 707     PERL_CONTEXT * cx;
 708
 709     PERL_ARGS_ASSERT_CX_PUSHBLOCK;
 710
 711     CXINC;
 712     cx = CX_CUR();
 713     cx->cx_type        = type;
 714     cx->blk_gimme      = gimme;
 715     cx->blk_oldsaveix  = saveix;
 716     cx->blk_oldsp      = (I32)(sp - PL_stack_base);
 717     cx->blk_oldcop     = PL_curcop;
 718     cx->blk_oldmarksp  = (I32)(PL_markstack_ptr - PL_markstack);
 719     cx->blk_oldscopesp = PL_scopestack_ix;
 720     cx->blk_oldpm      = PL_curpm;
 721     cx->blk_old_tmpsfloor = PL_tmps_floor;
 722
 723     PL_tmps_floor        = PL_tmps_ix;
 724     CX_DEBUG(cx, "PUSH");
 725     return cx;
 726 }
 727
 728
 729 /* Exit a block (RETURN and LAST). */
 730
 731 PERL_STATIC_INLINE void
 732 S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
 733 {
 734     PERL_ARGS_ASSERT_CX_POPBLOCK;
 735
 736     CX_DEBUG(cx, "POP");
 737     /* these 3 are common to cx_popblock and cx_topblock */
 738     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
 739     PL_scopestack_ix = cx->blk_oldscopesp;
 740     PL_curpm         = cx->blk_oldpm;
 741
 742     /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
 743      * and leaves a CX entry lying around for repeated use, so
 744      * skip for multicall */                  \
 745     assert(   (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
 746             || PL_savestack_ix == cx->blk_oldsaveix);
 747     PL_curcop     = cx->blk_oldcop;
 748     PL_tmps_floor = cx->blk_old_tmpsfloor;
 749 }
 750
 751 /* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
 752  * Whereas cx_popblock() restores the state to the point just before
 753  * cx_pushblock() was called,  cx_topblock() restores it to the point just
 754  * *after* cx_pushblock() was called. */
 755
 756 PERL_STATIC_INLINE void
 757 S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
 758 {
 759     PERL_ARGS_ASSERT_CX_TOPBLOCK;
 760
 761     CX_DEBUG(cx, "TOP");
 762     /* these 3 are common to cx_popblock and cx_topblock */
 763     PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
 764     PL_scopestack_ix = cx->blk_oldscopesp;
 765     PL_curpm         = cx->blk_oldpm;
 766
 767     PL_stack_sp      = PL_stack_base + cx->blk_oldsp;
 768 }
 769
 770
 771 PERL_STATIC_INLINE void
 772 S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
 773 {
 774     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
 775
 776     PERL_ARGS_ASSERT_CX_PUSHSUB;
 777
 778     PERL_DTRACE_PROBE_ENTRY(cv);
 779     cx->blk_sub.cv = cv;
 780     cx->blk_sub.olddepth = CvDEPTH(cv);
 781     cx->blk_sub.prevcomppad = PL_comppad;
 782     cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
 783     cx->blk_sub.retop = retop;
 784     SvREFCNT_inc_simple_void_NN(cv);
 785     cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
 786 }
 787
 788
 789 /* subsets of cx_popsub() */
 790
 791 PERL_STATIC_INLINE void
 792 S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
 793 {
 794     CV *cv;
 795
 796     PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
 797     assert(CxTYPE(cx) == CXt_SUB);
 798
 799     PL_comppad = cx->blk_sub.prevcomppad;
 800     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
 801     cv = cx->blk_sub.cv;
 802     CvDEPTH(cv) = cx->blk_sub.olddepth;
 803     cx->blk_sub.cv = NULL;
 804     SvREFCNT_dec(cv);
 805 }
 806
 807
 808 /* handle the @_ part of leaving a sub */
 809
 810 PERL_STATIC_INLINE void
 811 S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
 812 {
 813     AV *av;
 814
 815     PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
 816     assert(CxTYPE(cx) == CXt_SUB);
 817     assert(AvARRAY(MUTABLE_AV(
 818         PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
 819                 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
 820
 821     CX_POP_SAVEARRAY(cx);
 822     av = MUTABLE_AV(PAD_SVl(0));
 823     if (UNLIKELY(AvREAL(av)))
 824         /* abandon @_ if it got reified */
 825         clear_defarray(av, 0);
 826     else {
 827         CLEAR_ARGARRAY(av);
 828     }
 829 }
 830
 831
 832 PERL_STATIC_INLINE void
 833 S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
 834 {
 835     PERL_ARGS_ASSERT_CX_POPSUB;
 836     assert(CxTYPE(cx) == CXt_SUB);
 837
 838     PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
 839
 840     if (CxHASARGS(cx))
 841         cx_popsub_args(cx);
 842     cx_popsub_common(cx);
 843 }
 844
 845
 846 PERL_STATIC_INLINE void
 847 S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
 848 {
 849     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
 850
 851     cx->blk_format.cv          = cv;
 852     cx->blk_format.retop       = retop;
 853     cx->blk_format.gv          = gv;
 854     cx->blk_format.dfoutgv     = PL_defoutgv;
 855     cx->blk_format.prevcomppad = PL_comppad;
 856     cx->blk_u16                = 0;
 857
 858     SvREFCNT_inc_simple_void_NN(cv);
 859     CvDEPTH(cv)++;
 860     SvREFCNT_inc_void(cx->blk_format.dfoutgv);
 861 }
 862
 863
 864 PERL_STATIC_INLINE void
 865 S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
 866 {
 867     CV *cv;
 868     GV *dfout;
 869
 870     PERL_ARGS_ASSERT_CX_POPFORMAT;
 871     assert(CxTYPE(cx) == CXt_FORMAT);
 872
 873     dfout = cx->blk_format.dfoutgv;
 874     setdefout(dfout);
 875     cx->blk_format.dfoutgv = NULL;
 876     SvREFCNT_dec_NN(dfout);
 877
 878     PL_comppad = cx->blk_format.prevcomppad;
 879     PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
 880     cv = cx->blk_format.cv;
 881     cx->blk_format.cv = NULL;
 882     --CvDEPTH(cv);
 883     SvREFCNT_dec_NN(cv);
 884 }
 885
 886
 887 PERL_STATIC_INLINE void
 888 S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
 889 {
 890     PERL_ARGS_ASSERT_CX_PUSHEVAL;
 891
 892     cx->blk_eval.retop         = retop;
 893     cx->blk_eval.old_namesv    = namesv;
 894     cx->blk_eval.old_eval_root = PL_eval_root;
 895     cx->blk_eval.cur_text      = PL_parser ? PL_parser->linestr : NULL;
 896     cx->blk_eval.cv            = NULL; /* later set by doeval_compile() */
 897     cx->blk_eval.cur_top_env   = PL_top_env;
 898
 899     assert(!(PL_in_eval     & ~ 0x7F));
 900     assert(!(PL_op->op_type & ~0x1FF));
 901     cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
 902 }
 903
 904
 905 PERL_STATIC_INLINE void
 906 S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
 907 {
 908     SV *sv;
 909
 910     PERL_ARGS_ASSERT_CX_POPEVAL;
 911     assert(CxTYPE(cx) == CXt_EVAL);
 912
 913     PL_in_eval = CxOLD_IN_EVAL(cx);
 914     PL_eval_root = cx->blk_eval.old_eval_root;
 915     sv = cx->blk_eval.cur_text;
 916     if (sv && SvSCREAM(sv)) {
 917         cx->blk_eval.cur_text = NULL;
 918         SvREFCNT_dec_NN(sv);
 919     }
 920
 921     sv = cx->blk_eval.old_namesv;
 922     if (sv) {
 923         cx->blk_eval.old_namesv = NULL;
 924         SvREFCNT_dec_NN(sv);
 925     }
 926 }
 927
 928
 929 /* push a plain loop, i.e.
 930  *     { block }
 931  *     while (cond) { block }
 932  *     for (init;cond;continue) { block }
 933  * This loop can be last/redo'ed etc.
 934  */
 935
 936 PERL_STATIC_INLINE void
 937 S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
 938 {
 939     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
 940     cx->blk_loop.my_op = cLOOP;
 941 }
 942
 943
 944 /* push a true for loop, i.e.
 945  *     for var (list) { block }
 946  */
 947
 948 PERL_STATIC_INLINE void
 949 S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
 950 {
 951     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
 952
 953     /* this one line is common with cx_pushloop_plain */
 954     cx->blk_loop.my_op = cLOOP;
 955
 956     cx->blk_loop.itervar_u.svp = (SV**)itervarp;
 957     cx->blk_loop.itersave      = itersave;
 958 #ifdef USE_ITHREADS
 959     cx->blk_loop.oldcomppad = PL_comppad;
 960 #endif
 961 }
 962
 963
 964 /* pop all loop types, including plain */
 965
 966 PERL_STATIC_INLINE void
 967 S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
 968 {
 969     PERL_ARGS_ASSERT_CX_POPLOOP;
 970
 971     assert(CxTYPE_is_LOOP(cx));
 972     if (  CxTYPE(cx) == CXt_LOOP_ARY
 973        || CxTYPE(cx) == CXt_LOOP_LAZYSV)
 974     {
 975         /* Free ary or cur. This assumes that state_u.ary.ary
 976          * aligns with state_u.lazysv.cur. See cx_dup() */
 977         SV *sv = cx->blk_loop.state_u.lazysv.cur;
 978         cx->blk_loop.state_u.lazysv.cur = NULL;
 979         SvREFCNT_dec_NN(sv);
 980         if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
 981             sv = cx->blk_loop.state_u.lazysv.end;
 982             cx->blk_loop.state_u.lazysv.end = NULL;
 983             SvREFCNT_dec_NN(sv);
 984         }
 985     }
 986     if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
 987         SV *cursv;
 988         SV **svp = (cx)->blk_loop.itervar_u.svp;
 989         if ((cx->cx_type & CXp_FOR_GV))
 990             svp = &GvSV((GV*)svp);
 991         cursv = *svp;
 992         *svp = cx->blk_loop.itersave;
 993         cx->blk_loop.itersave = NULL;
 994         SvREFCNT_dec(cursv);
 995     }
 996 }
 997
 998
 999 PERL_STATIC_INLINE void
1000 S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
1001 {
1002     PERL_ARGS_ASSERT_CX_PUSHWHEN;
1003
1004     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1005 }
1006
1007
1008 PERL_STATIC_INLINE void
1009 S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1010 {
1011     PERL_ARGS_ASSERT_CX_POPWHEN;
1012     assert(CxTYPE(cx) == CXt_WHEN);
1013
1014     PERL_UNUSED_ARG(cx);
1015     PERL_UNUSED_CONTEXT;
1016     /* currently NOOP */
1017 }
1018
1019
1020 PERL_STATIC_INLINE void
1021 S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1022 {
1023     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1024
1025     cx->blk_givwhen.leave_op = cLOGOP->op_other;
1026     cx->blk_givwhen.defsv_save = orig_defsv;
1027 }
1028
1029
1030 PERL_STATIC_INLINE void
1031 S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1032 {
1033     SV *sv;
1034
1035     PERL_ARGS_ASSERT_CX_POPGIVEN;
1036     assert(CxTYPE(cx) == CXt_GIVEN);
1037
1038     sv = GvSV(PL_defgv);
1039     GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1040     cx->blk_givwhen.defsv_save = NULL;
1041     SvREFCNT_dec(sv);
1042 }
1043
1044 /*
1045  * ex: set ts=8 sts=4 sw=4 et:
1046  */