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