diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/sv_inline.h')
-rwxr-xr-x | systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/sv_inline.h | 1002 |
1 files changed, 1002 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/sv_inline.h b/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/sv_inline.h new file mode 100755 index 0000000000..3adc130575 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/sv_inline.h @@ -0,0 +1,1002 @@ +/* sv_inline.h + * + * Copyright (C) 2022 by Larry Wall and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* This file contains the newSV_type and newSV_type_mortal functions, as well as + * the various struct and macro definitions they require. In the main, these + * definitions were moved from sv.c, where many of them continue to also be used. + * (In Perl_more_bodies, Perl_sv_upgrade and Perl_sv_clear, for example.) Code + * comments associated with definitions and functions were also copied across + * verbatim. + * + * The rationale for having these as inline functions, rather than in sv.c, is + * that the target type is very often known at compile time, and therefore + * optimum code can be emitted by the compiler, rather than having all calls + * traverse the many branches of Perl_sv_upgrade at runtime. + */ + +/* This definition came from perl.h*/ + +/* The old value was hard coded at 1008. (4096-16) seems to be a bit faster, + at least on FreeBSD. YMMV, so experiment. */ +#ifndef PERL_ARENA_SIZE +#define PERL_ARENA_SIZE 4080 +#endif + +/* All other pre-existing definitions and functions that were moved into this + * file originally came from sv.c. */ + +#ifdef PERL_POISON +# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) +# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) +/* Whilst I'd love to do this, it seems that things like to check on + unreferenced scalars +# define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) +*/ +# define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ + PoisonNew(&SvREFCNT(sv), 1, U32) +#else +# define SvARENA_CHAIN(sv) SvANY(sv) +# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) +# define POISON_SV_HEAD(sv) +#endif + +#ifdef PERL_MEM_LOG +# define MEM_LOG_NEW_SV(sv, file, line, func) \ + Perl_mem_log_new_sv(sv, file, line, func) +# define MEM_LOG_DEL_SV(sv, file, line, func) \ + Perl_mem_log_del_sv(sv, file, line, func) +#else +# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP +# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP +#endif + +#define uproot_SV(p) \ + STMT_START { \ + (p) = PL_sv_root; \ + PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ + ++PL_sv_count; \ + } STMT_END + +/* Perl_more_sv lives in sv.c, we don't want to inline it. + * but the function declaration seems to be needed. */ +SV* Perl_more_sv(pTHX); + +/* new_SV(): return a new, empty SV head */ + +#ifdef DEBUG_LEAKING_SCALARS +/* provide a real function for a debugger to play with */ +STATIC SV* +S_new_SV(pTHX_ const char *file, int line, const char *func) +{ + SV* sv; + + if (PL_sv_root) + uproot_SV(sv); + else + sv = Perl_more_sv(aTHX); + SvANY(sv) = 0; + SvREFCNT(sv) = 1; + SvFLAGS(sv) = 0; + sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; + sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE + ? PL_parser->copline + : PL_curcop + ? CopLINE(PL_curcop) + : 0 + ); + sv->sv_debug_inpad = 0; + sv->sv_debug_parent = NULL; + sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; + + sv->sv_debug_serial = PL_sv_serial++; + + MEM_LOG_NEW_SV(sv, file, line, func); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n", + PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); + + return sv; +} +# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) + +#else +# define new_SV(p) \ + STMT_START { \ + if (PL_sv_root) \ + uproot_SV(p); \ + else \ + (p) = Perl_more_sv(aTHX); \ + SvANY(p) = 0; \ + SvREFCNT(p) = 1; \ + SvFLAGS(p) = 0; \ + MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ + } STMT_END +#endif + + +typedef struct xpvhv_with_aux XPVHV_WITH_AUX; + +struct body_details { + U8 body_size; /* Size to allocate */ + U8 copy; /* Size of structure to copy (may be shorter) */ + U8 offset; /* Size of unalloced ghost fields to first alloced field*/ + PERL_BITFIELD8 type : 5; /* We have space for a sanity check. */ + PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */ + PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */ + PERL_BITFIELD8 arena : 1; /* Allocated from an arena */ + U32 arena_size; /* Size of arena to allocate */ +}; + +#define ALIGNED_TYPE_NAME(name) name##_aligned +#define ALIGNED_TYPE(name) \ + typedef union { \ + name align_me; \ + NV nv; \ + IV iv; \ + } ALIGNED_TYPE_NAME(name) + +ALIGNED_TYPE(regexp); +ALIGNED_TYPE(XPVGV); +ALIGNED_TYPE(XPVLV); +ALIGNED_TYPE(XPVAV); +ALIGNED_TYPE(XPVHV); +ALIGNED_TYPE(XPVHV_WITH_AUX); +ALIGNED_TYPE(XPVCV); +ALIGNED_TYPE(XPVFM); +ALIGNED_TYPE(XPVIO); +ALIGNED_TYPE(XPVOBJ); + +#define HADNV FALSE +#define NONV TRUE + + +#ifdef PURIFY +/* With -DPURFIY we allocate everything directly, and don't use arenas. + This seems a rather elegant way to simplify some of the code below. */ +#define HASARENA FALSE +#else +#define HASARENA TRUE +#endif +#define NOARENA FALSE + +/* Size the arenas to exactly fit a given number of bodies. A count + of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, + simplifying the default. If count > 0, the arena is sized to fit + only that many bodies, allowing arenas to be used for large, rare + bodies (XPVFM, XPVIO) without undue waste. The arena size is + limited by PERL_ARENA_SIZE, so we can safely oversize the + declarations. + */ +#define FIT_ARENA0(body_size) \ + ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) +#define FIT_ARENAn(count,body_size) \ + ( count * body_size <= PERL_ARENA_SIZE) \ + ? count * body_size \ + : FIT_ARENA0 (body_size) +#define FIT_ARENA(count,body_size) \ + (U32)(count \ + ? FIT_ARENAn (count, body_size) \ + : FIT_ARENA0 (body_size)) + +/* Calculate the length to copy. Specifically work out the length less any + final padding the compiler needed to add. See the comment in sv_upgrade + for why copying the padding proved to be a bug. */ + +#define copy_length(type, last_member) \ + STRUCT_OFFSET(type, last_member) \ + + sizeof (((type*)SvANY((const SV *)0))->last_member) + +static const struct body_details bodies_by_type[] = { + /* HEs use this offset for their arena. */ + { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, + + /* IVs are in the head, so the allocation size is 0. */ + { 0, + sizeof(IV), /* This is used to copy out the IV body. */ + STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, + NOARENA /* IVS don't need an arena */, 0 + }, + +#if NVSIZE <= IVSIZE + { 0, sizeof(NV), + STRUCT_OFFSET(XPVNV, xnv_u), + SVt_NV, FALSE, HADNV, NOARENA, 0 }, +#else + { sizeof(NV), sizeof(NV), + STRUCT_OFFSET(XPVNV, xnv_u), + SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, +#endif + + { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_PV, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_INVLIST, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_PVIV, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), + copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), + + STRUCT_OFFSET(XPV, xpv_cur), + SVt_PVNV, FALSE, HADNV, HASARENA, + FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, + + { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, + + { sizeof(ALIGNED_TYPE_NAME(regexp)), + sizeof(regexp), + 0, + SVt_REGEXP, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp))) + }, + + { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVAV)), + copy_length(XPVAV, xav_alloc), + 0, + SVt_PVAV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVHV)), + copy_length(XPVHV, xhv_max), + 0, + SVt_PVHV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVCV)), + sizeof(XPVCV), + 0, + SVt_PVCV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVFM)), + sizeof(XPVFM), + 0, + SVt_PVFM, TRUE, NONV, NOARENA, + FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVIO)), + sizeof(XPVIO), + 0, + SVt_PVIO, TRUE, NONV, HASARENA, + FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) }, + + { sizeof(ALIGNED_TYPE_NAME(XPVOBJ)), + copy_length(XPVOBJ, xobject_fields), + 0, + SVt_PVOBJ, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVOBJ))) }, +}; + +#define new_body_allocated(sv_type) \ + (void *)((char *)S_new_body(aTHX_ sv_type) \ + - bodies_by_type[sv_type].offset) + +#ifdef PURIFY +#if !(NVSIZE <= IVSIZE) +# define new_XNV() safemalloc(sizeof(XPVNV)) +#endif +#define new_XPVNV() safemalloc(sizeof(XPVNV)) +#define new_XPVMG() safemalloc(sizeof(XPVMG)) + +#define del_body_by_type(p, type) safefree(p) + +#else /* !PURIFY */ + +#if !(NVSIZE <= IVSIZE) +# define new_XNV() new_body_allocated(SVt_NV) +#endif +#define new_XPVNV() new_body_allocated(SVt_PVNV) +#define new_XPVMG() new_body_allocated(SVt_PVMG) + +#define del_body_by_type(p, type) \ + del_body(p + bodies_by_type[(type)].offset, \ + &PL_body_roots[(type)]) + +#endif /* PURIFY */ + +/* no arena for you! */ + +#define new_NOARENA(details) \ + safemalloc((details)->body_size + (details)->offset) +#define new_NOARENAZ(details) \ + safecalloc((details)->body_size + (details)->offset, 1) + +#ifndef PURIFY + +/* grab a new thing from the arena's free list, allocating more if necessary. */ +#define new_body_from_arena(xpv, root_index, type_meta) \ + STMT_START { \ + void ** const r3wt = &PL_body_roots[root_index]; \ + xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ + ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ root_index, \ + type_meta.body_size,\ + type_meta.arena_size)); \ + *(r3wt) = *(void**)(xpv); \ + } STMT_END + +PERL_STATIC_INLINE void * +S_new_body(pTHX_ const svtype sv_type) +{ + void *xpv; + new_body_from_arena(xpv, sv_type, bodies_by_type[sv_type]); + return xpv; +} + +#endif + +static const struct body_details fake_rv = + { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; + +static const struct body_details fake_hv_with_aux = + /* The SVt_IV arena is used for (larger) PVHV bodies. */ + { sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX)), + copy_length(XPVHV, xhv_max), + 0, + SVt_PVHV, TRUE, NONV, HASARENA, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV_WITH_AUX))) }; + +/* +=for apidoc newSV_type + +Creates a new SV, of the type specified. The reference count for the new SV +is set to 1. + +=cut +*/ + +PERL_STATIC_INLINE SV * +Perl_newSV_type(pTHX_ const svtype type) +{ + SV *sv; + void* new_body; + const struct body_details *type_details; + + new_SV(sv); + + type_details = bodies_by_type + type; + + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= type; + + switch (type) { + case SVt_NULL: + break; + case SVt_IV: + SET_SVANY_FOR_BODYLESS_IV(sv); + SvIV_set(sv, 0); + break; + case SVt_NV: +#if NVSIZE <= IVSIZE + SET_SVANY_FOR_BODYLESS_NV(sv); +#else + SvANY(sv) = new_XNV(); +#endif + SvNV_set(sv, 0); + break; + case SVt_PVHV: + case SVt_PVAV: + case SVt_PVOBJ: + assert(type_details->body_size); + +#ifndef PURIFY + assert(type_details->arena); + assert(type_details->arena_size); + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + /* xpvav and xpvhv have no offset, so no need to adjust new_body */ + assert(!(type_details->offset)); +#else + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + new_body = new_NOARENAZ(type_details); +#endif + SvANY(sv) = new_body; + + SvSTASH_set(sv, NULL); + SvMAGIC_set(sv, NULL); + + switch(type) { + case SVt_PVAV: + AvFILLp(sv) = -1; + AvMAX(sv) = -1; + AvALLOC(sv) = NULL; + + AvREAL_only(sv); + break; + case SVt_PVHV: + HvTOTALKEYS(sv) = 0; + /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ + HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; + + assert(!SvOK(sv)); + SvOK_off(sv); +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(sv); /* key-sharing on by default */ +#endif + /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ + HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; + break; + case SVt_PVOBJ: + ObjectMAXFIELD(sv) = -1; + ObjectFIELDS(sv) = NULL; + break; + default: + NOT_REACHED; + } + + sv->sv_u.svu_array = NULL; /* or svu_hash */ + break; + + case SVt_PVIV: + case SVt_PVIO: + case SVt_PVGV: + case SVt_PVCV: + case SVt_PVLV: + case SVt_INVLIST: + case SVt_REGEXP: + case SVt_PVMG: + case SVt_PVNV: + case SVt_PV: + /* For a type known at compile time, it should be possible for the + * compiler to deduce the value of (type_details->arena), resolve + * that branch below, and inline the relevant values from + * bodies_by_type. Except, at least for gcc, it seems not to do that. + * We help it out here with two deviations from sv_upgrade: + * (1) Minor rearrangement here, so that PVFM - the only type at this + * point not to be allocated from an array appears last, not PV. + * (2) The ASSUME() statement here for everything that isn't PVFM. + * Obviously this all only holds as long as it's a true reflection of + * the bodies_by_type lookup table. */ +#ifndef PURIFY + ASSUME(type_details->arena); +#endif + /* FALLTHROUGH */ + case SVt_PVFM: + + assert(type_details->body_size); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ +#ifndef PURIFY + if(type_details->arena) { + /* This points to the start of the allocated area. */ + new_body = S_new_body(aTHX_ type); + Zero(new_body, type_details->body_size, char); + new_body = ((char *)new_body) - type_details->offset; + } else +#endif + { + new_body = new_NOARENAZ(type_details); + } + SvANY(sv) = new_body; + + if (UNLIKELY(type == SVt_PVIO)) { + IO * const io = MUTABLE_IO(sv); + GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); + + SvOBJECT_on(io); + /* Clear the stashcache because a new IO could overrule a package + name */ + DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); + hv_clear(PL_stashcache); + + SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); + IoPAGE_LEN(sv) = 60; + } + + sv->sv_u.svu_rv = NULL; + break; + default: + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", + (unsigned long)type); + } + + return sv; +} + +/* +=for apidoc newSV_type_mortal + +Creates a new mortal SV, of the type specified. The reference count for the +new SV is set to 1. + +This is equivalent to + SV* sv = sv_2mortal(newSV_type(<some type>)) +and + SV* sv = sv_newmortal(); + sv_upgrade(sv, <some_type>) +but should be more efficient than both of them. (Unless sv_2mortal is inlined +at some point in the future.) + +=cut +*/ + +PERL_STATIC_INLINE SV * +Perl_newSV_type_mortal(pTHX_ const svtype type) +{ + SV *sv = newSV_type(type); + SSize_t ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + ix = Perl_tmps_grow_p(aTHX_ ix); + PL_tmps_stack[ix] = (sv); + SvTEMP_on(sv); + return sv; +} + +/* The following functions started out in sv.h and then moved to inline.h. They + * moved again into this file during the 5.37.x development cycle. */ + +/* +=for apidoc_section $SV +=for apidoc SvPVXtrue + +Returns a boolean as to whether or not C<sv> contains a PV that is considered +TRUE. FALSE is returned if C<sv> doesn't contain a PV, or if the PV it does +contain is zero length, or consists of just the single character '0'. Every +other PV value is considered TRUE. + +As of Perl v5.37.1, C<sv> is evaluated exactly once; in earlier releases, it +could be evaluated more than once. + +=cut +*/ + +PERL_STATIC_INLINE bool +Perl_SvPVXtrue(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVPVXTRUE; + + if (! (XPV *) SvANY(sv)) { + return false; + } + + if ( ((XPV *) SvANY(sv))->xpv_cur > 1) { /* length > 1 */ + return true; + } + + if (( (XPV *) SvANY(sv))->xpv_cur == 0) { + return false; + } + + return *sv->sv_u.svu_pv != '0'; +} + +/* +=for apidoc SvGETMAGIC +Invokes C<L</mg_get>> on an SV if it has 'get' magic. For example, this +will call C<FETCH> on a tied variable. As of 5.37.1, this function is +guaranteed to evaluate its argument exactly once. + +=cut +*/ + +PERL_STATIC_INLINE void +Perl_SvGETMAGIC(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVGETMAGIC; + + if (UNLIKELY(SvGMAGICAL(sv))) { + mg_get(sv); + } +} + +PERL_STATIC_INLINE bool +Perl_SvTRUE(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVTRUE; + + if (UNLIKELY(sv == NULL)) + return FALSE; + SvGETMAGIC(sv); + return SvTRUE_nomg_NN(sv); +} + +PERL_STATIC_INLINE bool +Perl_SvTRUE_nomg(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVTRUE_NOMG; + + if (UNLIKELY(sv == NULL)) + return FALSE; + return SvTRUE_nomg_NN(sv); +} + +PERL_STATIC_INLINE bool +Perl_SvTRUE_NN(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVTRUE_NN; + + SvGETMAGIC(sv); + return SvTRUE_nomg_NN(sv); +} + +PERL_STATIC_INLINE bool +Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback) +{ + PERL_ARGS_ASSERT_SVTRUE_COMMON; + + if (UNLIKELY(SvIMMORTAL_INTERP(sv))) + return SvIMMORTAL_TRUE(sv); + + if (! SvOK(sv)) + return FALSE; + + if (SvPOK(sv)) + return SvPVXtrue(sv); + + if (SvIOK(sv)) + return SvIVX(sv) != 0; /* casts to bool */ + + if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv))))) + return TRUE; + + if (sv_2bool_is_fallback) + return sv_2bool_nomg(sv); + + return isGV_with_GP(sv); +} + +PERL_STATIC_INLINE SV * +Perl_SvREFCNT_inc(SV *sv) +{ + if (LIKELY(sv != NULL)) + SvREFCNT(sv)++; + return sv; +} + +PERL_STATIC_INLINE SV * +Perl_SvREFCNT_inc_NN(SV *sv) +{ + PERL_ARGS_ASSERT_SVREFCNT_INC_NN; + + SvREFCNT(sv)++; + return sv; +} + +PERL_STATIC_INLINE void +Perl_SvREFCNT_inc_void(SV *sv) +{ + if (LIKELY(sv != NULL)) + SvREFCNT(sv)++; +} + +PERL_STATIC_INLINE void +Perl_SvREFCNT_dec(pTHX_ SV *sv) +{ + if (LIKELY(sv != NULL)) { + U32 rc = SvREFCNT(sv); + if (LIKELY(rc > 1)) + SvREFCNT(sv) = rc - 1; + else + Perl_sv_free2(aTHX_ sv, rc); + } +} + +PERL_STATIC_INLINE SV * +Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVREFCNT_DEC_RET_NULL; + Perl_SvREFCNT_dec(aTHX_ sv); + return NULL; +} + + +PERL_STATIC_INLINE void +Perl_SvREFCNT_dec_NN(pTHX_ SV *sv) +{ + U32 rc = SvREFCNT(sv); + + PERL_ARGS_ASSERT_SVREFCNT_DEC_NN; + + if (LIKELY(rc > 1)) + SvREFCNT(sv) = rc - 1; + else + Perl_sv_free2(aTHX_ sv, rc); +} + +/* +=for apidoc SvAMAGIC_on + +Indicate that C<sv> has overloading (active magic) enabled. + +=cut +*/ + +PERL_STATIC_INLINE void +Perl_SvAMAGIC_on(SV *sv) +{ + PERL_ARGS_ASSERT_SVAMAGIC_ON; + assert(SvROK(sv)); + + if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv))); +} + +/* +=for apidoc SvAMAGIC_off + +Indicate that C<sv> has overloading (active magic) disabled. + +=cut +*/ + +PERL_STATIC_INLINE void +Perl_SvAMAGIC_off(SV *sv) +{ + PERL_ARGS_ASSERT_SVAMAGIC_OFF; + + if (SvROK(sv) && SvOBJECT(SvRV(sv))) + HvAMAGIC_off(SvSTASH(SvRV(sv))); +} + +PERL_STATIC_INLINE U32 +Perl_SvPADSTALE_on(SV *sv) +{ + assert(!(SvFLAGS(sv) & SVs_PADTMP)); + return SvFLAGS(sv) |= SVs_PADSTALE; +} +PERL_STATIC_INLINE U32 +Perl_SvPADSTALE_off(SV *sv) +{ + assert(!(SvFLAGS(sv) & SVs_PADTMP)); + return SvFLAGS(sv) &= ~SVs_PADSTALE; +} + +/* +=for apidoc_section $SV +=for apidoc SvIV +=for apidoc_item SvIV_nomg +=for apidoc_item SvIVx + +These each coerce the given SV to IV and return it. The returned value in many +circumstances will get stored in C<sv>'s IV slot, but not in all cases. (Use +C<L</sv_setiv>> to make sure it does). + +As of 5.37.1, all are guaranteed to evaluate C<sv> only once. + +C<SvIVx> is now identical to C<SvIV>, but prior to 5.37.1, it was the only form +guaranteed to evaluate C<sv> only once. + +C<SvIV_nomg> is the same as C<SvIV>, but does not perform 'get' magic. + +=for apidoc SvNV +=for apidoc_item SvNV_nomg +=for apidoc_item SvNVx + +These each coerce the given SV to NV and return it. The returned value in many +circumstances will get stored in C<sv>'s NV slot, but not in all cases. (Use +C<L</sv_setnv>> to make sure it does). + +As of 5.37.1, all are guaranteed to evaluate C<sv> only once. + +C<SvNVx> is now identical to C<SvNV>, but prior to 5.37.1, it was the only form +guaranteed to evaluate C<sv> only once. + +C<SvNV_nomg> is the same as C<SvNV>, but does not perform 'get' magic. + +=for apidoc SvUV +=for apidoc_item SvUV_nomg +=for apidoc_item SvUVx + +These each coerce the given SV to UV and return it. The returned value in many +circumstances will get stored in C<sv>'s UV slot, but not in all cases. (Use +C<L</sv_setuv>> to make sure it does). + +As of 5.37.1, all are guaranteed to evaluate C<sv> only once. + +C<SvUVx> is now identical to C<SvUV>, but prior to 5.37.1, it was the only form +guaranteed to evaluate C<sv> only once. + +=cut +*/ + +PERL_STATIC_INLINE IV +Perl_SvIV(pTHX_ SV *sv) { + PERL_ARGS_ASSERT_SVIV; + + if (SvIOK_nog(sv)) + return SvIVX(sv); + return sv_2iv(sv); +} + +PERL_STATIC_INLINE UV +Perl_SvUV(pTHX_ SV *sv) { + PERL_ARGS_ASSERT_SVUV; + + if (SvUOK_nog(sv)) + return SvUVX(sv); + return sv_2uv(sv); +} + +PERL_STATIC_INLINE NV +Perl_SvNV(pTHX_ SV *sv) { + PERL_ARGS_ASSERT_SVNV; + + if (SvNOK_nog(sv)) + return SvNVX(sv); + return sv_2nv(sv); +} + +PERL_STATIC_INLINE IV +Perl_SvIV_nomg(pTHX_ SV *sv) { + PERL_ARGS_ASSERT_SVIV_NOMG; + + if (SvIOK(sv)) + return SvIVX(sv); + return sv_2iv_flags(sv, 0); +} + +PERL_STATIC_INLINE UV +Perl_SvUV_nomg(pTHX_ SV *sv) { + PERL_ARGS_ASSERT_SVUV_NOMG; + + if (SvIOK_nog(sv)) + return SvUVX(sv); + return sv_2uv_flags(sv, 0); +} + +PERL_STATIC_INLINE NV +Perl_SvNV_nomg(pTHX_ SV *sv) { + PERL_ARGS_ASSERT_SVNV_NOMG; + + if (SvNOK_nog(sv)) + return SvNVX(sv); + return sv_2nv_flags(sv, 0); +} + +#if defined(PERL_CORE) || defined (PERL_EXT) +PERL_STATIC_INLINE STRLEN +S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) +{ + PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B; + if (SvGAMAGIC(sv)) { + U8 *hopped = utf8_hop((U8 *)pv, pos); + if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); + return (STRLEN)(hopped - (U8 *)pv); + } + return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN); +} +#endif + +PERL_STATIC_INLINE char * +Perl_sv_pvutf8n_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy) +{ + /* This is just so can be passed to Perl_SvPV_helper() as a function + * pointer with the same signature as all the other such pointers, and + * having hence an unused parameter */ + PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE_WRAPPER; + PERL_UNUSED_ARG(dummy); + + return sv_pvutf8n_force(sv, lp); +} + +PERL_STATIC_INLINE char * +Perl_sv_pvbyten_force_wrapper(pTHX_ SV * const sv, STRLEN * const lp, const U32 dummy) +{ + /* This is just so can be passed to Perl_SvPV_helper() as a function + * pointer with the same signature as all the other such pointers, and + * having hence an unused parameter */ + PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE_WRAPPER; + PERL_UNUSED_ARG(dummy); + + return sv_pvbyten_force(sv, lp); +} + +PERL_STATIC_INLINE char * +Perl_SvPV_helper(pTHX_ + SV * const sv, + STRLEN * const lp, + const U32 flags, + const PL_SvPVtype type, + char * (*non_trivial)(pTHX_ SV *, STRLEN * const, const U32), + const bool or_null, + const U32 return_flags + ) +{ + /* 'type' should be known at compile time, so this is reduced to a single + * conditional at runtime */ + if ( (type == SvPVbyte_type_ && SvPOK_byte_nog(sv)) + || (type == SvPVforce_type_ && SvPOK_pure_nogthink(sv)) + || (type == SvPVutf8_type_ && SvPOK_utf8_nog(sv)) + || (type == SvPVnormal_type_ && SvPOK_nog(sv)) + || (type == SvPVutf8_pure_type_ && SvPOK_utf8_pure_nogthink(sv)) + || (type == SvPVbyte_pure_type_ && SvPOK_byte_pure_nogthink(sv)) + ) { + if (lp) { + *lp = SvCUR(sv); + } + + /* Similarly 'return_flags is known at compile time, so this becomes + * branchless */ + if (return_flags & SV_MUTABLE_RETURN) { + return SvPVX_mutable(sv); + } + else if(return_flags & SV_CONST_RETURN) { + return (char *) SvPVX_const(sv); + } + else { + return SvPVX(sv); + } + } + + if (or_null) { /* This is also known at compile time */ + if (flags & SV_GMAGIC) { /* As is this */ + SvGETMAGIC(sv); + } + + if (! SvOK(sv)) { + if (lp) { /* As is this */ + *lp = 0; + } + + return NULL; + } + } + + /* Can't trivially handle this, call the function */ + return non_trivial(aTHX_ sv, lp, (flags|return_flags)); +} + +/* +=for apidoc newRV_noinc + +Creates an RV wrapper for an SV. The reference count for the original +SV is B<not> incremented. + +=cut +*/ + +PERL_STATIC_INLINE SV * +Perl_newRV_noinc(pTHX_ SV *const tmpRef) +{ + SV *sv = newSV_type(SVt_IV); + + PERL_ARGS_ASSERT_NEWRV_NOINC; + + SvTEMP_off(tmpRef); + + /* inlined, simplified sv_setrv_noinc(sv, tmpRef); */ + SvRV_set(sv, tmpRef); + SvROK_on(sv); + + return sv; +} + +PERL_STATIC_INLINE char * +Perl_sv_setpv_freshbuf(pTHX_ SV *const sv) +{ + PERL_ARGS_ASSERT_SV_SETPV_FRESHBUF; + assert(SvTYPE(sv) >= SVt_PV); + assert(SvTYPE(sv) <= SVt_PVMG); + assert(!SvTHINKFIRST(sv)); + assert(SvPVX(sv)); + SvCUR_set(sv, 0); + *(SvEND(sv))= '\0'; + (void)SvPOK_only_UTF8(sv); + SvTAINT(sv); + return SvPVX(sv); +} + +/* + * ex: set ts=8 sts=4 sw=4 et: + */ |