/* ============================================================================
-=for apidoc_section $SV
An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
sv, av, hv...) contains type and reference count information, and for
many types, a pointer to the body (struct xrv, xpv, xpviv...), which
* "A time to plant, and a time to uproot what was planted..."
*/
-#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
-
#ifdef DEBUG_LEAKING_SCALARS
# define FREE_SV_DEBUG_FILE(sv) STMT_START { \
if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
# define DEBUG_SV_SERIAL(sv) NOOP
#endif
-#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
-
/* Mark an SV head as unused, and add to free list.
*
* If SVf_BREAK is set, skip adding it to the free list, as this SV had
--PL_sv_count; \
} STMT_END
-#define uproot_SV(p) \
- STMT_START { \
- (p) = PL_sv_root; \
- PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
- ++PL_sv_count; \
- } STMT_END
-
/* make some more SVs by adding another arena */
-STATIC SV*
-S_more_sv(pTHX)
+SV*
+Perl_more_sv(pTHX)
{
SV* sv;
char *chunk; /* must use New here to match call to */
return sv;
}
-/* 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 = S_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) = S_more_sv(aTHX); \
- SvANY(p) = 0; \
- SvREFCNT(p) = 1; \
- SvFLAGS(p) = 0; \
- MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
- } STMT_END
-#endif
-
-
/* del_SV(): return an empty SV head to the free list */
#ifdef DEBUGGING
}
/*
- Here are mid-level routines that manage the allocation of bodies out
- of the various arenas. There are 4 kinds of arenas:
+ Historically, here were mid-level routines that manage the
+ allocation of bodies out of the various arenas. Some of these
+ routines and related definitions remain here, but otherse were
+ moved into sv_inline.h to facilitate inlining of newSV_type().
+
+ There are 4 kinds of arenas:
1. SV-head arenas, which are discussed and handled above
2. regular body arenas
*/
-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 : 4; /* 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);
-
-#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))) },
-};
-
-#define new_body_allocated(sv_type) \
- (void *)((char *)S_new_body(aTHX_ sv_type) \
- - bodies_by_type[sv_type].offset)
-
/* return a thing to the free list */
#define del_body(thing, root) \
*root = (void*)thing_copy; \
} STMT_END
-#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)
void *
Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
}
}
-#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 sv_upgrade
PERL_ARGS_ASSERT_HV_AUXALLOC;
assert(SvTYPE(hv) == SVt_PVHV);
- assert(!SvOOK(hv));
+ assert(!HvHasAUX(hv));
#ifdef PURIFY
new_body = new_NOARENAZ(&fake_hv_with_aux);
#endif
SvANY(hv) = (XPVHV *) new_body;
- SvOOK_on(hv);
+ SvFLAGS(hv) |= SVphv_HasAUX;
return HvAUX(hv);
}
PTR2UV(sv), SvNVX(sv)));
#ifdef NV_PRESERVES_UV
- (void)SvIOKp_on(sv);
- (void)SvNOK_on(sv);
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- if (Perl_isnan(SvNVX(sv))) {
- SvUV_set(sv, 0);
- SvIsUV_on(sv);
- return FALSE;
- }
-#endif
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIV_set(sv, I_V(SvNVX(sv)));
- if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- } else {
- NOOP; /* Integer is imprecise. NOK, IOKp */
- }
- /* UV will not work better than IV */
- } else {
- if (SvNVX(sv) > (NV)UV_MAX) {
- SvIsUV_on(sv);
- /* Integer is inaccurate. NOK, IOKp, is UV */
- SvUV_set(sv, UV_MAX);
- } else {
- SvUV_set(sv, U_V(SvNVX(sv)));
- /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
- NV preservse UV so can do correct comparison. */
- if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
- SvIOK_on(sv);
- } else {
- NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
- }
- }
- SvIsUV_on(sv);
- }
+ SvNOKp_on(sv);
+ if (numtype)
+ SvNOK_on(sv);
+ goto got_nv; /* Fill IV/UV slot and set IOKp, maybe IOK */
#else /* NV_PRESERVES_UV */
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
assert (SvIOKp(sv));
} else {
if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ U_V(Perl_fabs(SvNVX(sv)))) {
/* Small enough to preserve all bits. */
(void)SvIOKp_on(sv);
SvNOK_on(sv);
SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv))
SvIOK_on(sv);
- /* Assumption: first non-preserved integer is < IV_MAX,
- this NV is in the preserved range, therefore: */
- if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
- < (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%" NVgf " U_V is 0x%" UVxf ", IV_MAX is 0x%" UVxf "\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
- }
+ /* There had been runtime checking for
+ "U_V(Perl_fabs(SvNVX(sv))) < (UV)IV_MAX" here to ensure
+ that this NV is in the preserved range, but this should
+ be always true if the following assertion is true: */
+ STATIC_ASSERT_STMT(((UV)1 << NV_PRESERVES_UV_BITS) <=
+ (UV)IV_MAX);
} else {
/* IN_UV NOT_INT
0 0 already failed to read UV.
# endif
}
}
-#endif /* NV_PRESERVES_UV */
/* It might be more code efficient to go through the entire logic above
and conditionally set with SvIOKp_on() rather than SvIOK(), but it
gets complex and potentially buggy, so more programmer efficient
to do it this way, by turning off the public flags: */
if (!numtype)
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+#endif /* NV_PRESERVES_UV */
}
}
else {
/* if that shift count is out of range then Configure's test is
wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
UV_BITS */
- if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(Perl_fabs(SvNVX(sv)))) {
SvNOK_on(sv); /* Definitely small enough to preserve all bits */
} else if (!(numtype & IS_NUMBER_IN_UV)) {
/* Can't use strtol etc to convert this string, so don't try.
}
/*
-=for apidoc sv_2pv_flags
+=for apidoc sv_2pv
+=for apidoc_item sv_2pv_flags
+
+These implement the various forms of the L<perlapi/C<SvPV>> macros.
+The macros are the preferred interface.
-Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
-If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. Coerces C<sv> to a
-string if necessary. Normally invoked via the C<SvPV_flags> macro.
-C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
+These return a pointer to the string value of an SV (coercing it to a string if
+necessary), and set C<*lp> to its length in bytes.
+
+The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
+C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
+C<SV_GMAGIC>.
+
+=for apidoc Amnh||SV_GMAGIC
=cut
*/
len = S_infnan_2pv(SvNVX(sv), s, size, 0);
if (len > 0) {
s += len;
- SvPOK_on(sv);
+ SvPOKp_on(sv);
}
else {
/* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
- SvPOK_on(sv);
+ SvPOKp_on(sv);
#else
{
bool local_radix;
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
STORE_LC_NUMERIC_SET_TO_NEEDED();
- local_radix = _NOT_IN_NUMERIC_STANDARD;
+ local_radix = NOT_IN_NUMERIC_STANDARD_;
if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
size += SvCUR(PL_numeric_radix_sv) - 1;
s = SvGROW_mutable(sv, size);
/*
=for apidoc sv_copypv
-=for apidoc_item sv_copypv_nomg
=for apidoc_item sv_copypv_flags
+=for apidoc_item sv_copypv_nomg
These copy a stringified representation of the source SV into the
destination SV. They automatically perform coercion of numeric values into
strings. Guaranteed to preserve the C<UTF8> flag even from overloaded objects.
Similar in nature to C<sv_2pv[_flags]> but they operate directly on an SV
-instead of just the string. Mostly they use L<perlintern/C<sv_2pv_flags>> to
+instead of just the string. Mostly they use L</C<sv_2pv_flags>> to
do the work, except when that would lose the UTF-8'ness of the PV.
The three forms differ only in whether or not they perform 'get magic' on
}
/*
-=for apidoc sv_2pvbyte
+=for apidoc sv_2pvbyte
+=for apidoc_item sv_2pvbyte_flags
-Returns a pointer to the byte-encoded representation of the SV, and set C<*lp>
-to its length. If the SV is marked as being encoded as UTF-8, it will
-downgrade it to a byte string as a side-effect, if possible. If the SV cannot
-be downgraded, this croaks.
+These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
+The macros are the preferred interface.
-Processes 'get' magic.
+These return a pointer to the byte-encoded representation of the SV, and set
+C<*lp> to its length. If the SV is marked as being encoded as UTF-8, it will
+be downgraded, if possible, to a byte string. If the SV cannot be downgraded,
+they croak.
-Usually accessed via the C<SvPVbyte> macro.
+The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
+C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
+C<SV_GMAGIC>.
+
+=for apidoc Amnh||SV_GMAGIC
=cut
*/
}
/*
-=for apidoc sv_2pvutf8
+=for apidoc sv_2pvutf8
+=for apidoc_item sv_2pvutf8_flags
+
+These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
+The macros are the preferred interface.
-Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
-to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
+These return a pointer to the UTF-8-encoded representation of the SV, and set
+C<*lp> to its length in bytes. They may cause the SV to be upgraded to UTF-8
+as a side-effect.
-Usually accessed via the C<SvPVutf8> macro.
+The forms differ in that plain C<sv_2pvutf8> always processes 'get' magic; and
+C<sv_2pvutf8_flags> processes 'get' magic if and only if C<flags> contains
+C<SV_GMAGIC>.
=cut
*/
/*
=for apidoc sv_utf8_upgrade
-=for apidoc_item sv_utf8_upgrade_nomg
=for apidoc_item sv_utf8_upgrade_flags
=for apidoc_item sv_utf8_upgrade_flags_grow
+=for apidoc_item sv_utf8_upgrade_nomg
These convert the PV of an SV to its UTF-8-encoded form.
The SV is forced to string form if it is not already.
C<sv_utf8_downgrade_nomg> does not.
C<sv_utf8_downgrade_flags> has an additional C<flags> parameter in which you can specify
-C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not proccess 'get' magic.
+C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not process 'get' magic.
=cut
*/
SV * const sref = (SV *)GvAV((const GV *)dsv);
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
- AV * const ary = newAV();
- av_push(ary, mg->mg_obj); /* takes the refcount */
+ AV * const ary = newAV_alloc_x(2);
+ av_push_simple(ary, mg->mg_obj); /* takes the refcount */
+ av_push_simple(ary, SvREFCNT_inc_simple_NN(dsv));
mg->mg_obj = (SV *)ary;
+ } else {
+ av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
}
- av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
}
else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
}
: NULL;
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
- AV * const ary = newAV();
- av_push(ary, mg->mg_obj); /* takes the refcount */
+ AV * const ary = newAV_alloc_xz(4);
+ av_push_simple(ary, mg->mg_obj); /* takes the refcount */
mg->mg_obj = (SV *)ary;
}
if (omg) {
}
if (sflags & SVp_NOK) {
SvNV_set(dsv, SvNVX(ssv));
+ if ((sflags & SVf_NOK) && !(sflags & SVf_POK)) {
+ /* Source was SVf_NOK|SVp_NOK|SVp_POK but not SVf_POK, meaning
+ a value set as floating point and later stringified, where
+ the value happens to be one of the few that we know aren't
+ affected by the numeric locale, hence we can cache the
+ stringification. Currently that's +Inf, -Inf and NaN, but
+ conceivably we might extend this to -9 .. +9 (excluding -0).
+ So mark destination the same: */
+ SvFLAGS(dsv) &= ~SVf_POK;
+ }
}
if (sflags & SVp_IOK) {
SvIV_set(dsv, SvIVX(ssv));
SvOK_off(sv);
}
+/*
+=for apidoc sv_set_true
+
+Equivalent to C<sv_setsv(sv, &PL_sv_yes)>, but may be made more
+efficient in the future. Doesn't handle set magic.
+
+The perl equivalent is C<$sv = !0;>.
+
+Introduced in perl 5.35.11.
+
+=cut
+*/
+
+void
+Perl_sv_set_true(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SV_SET_TRUE;
+ sv_setsv(sv, &PL_sv_yes);
+}
+
+/*
+=for apidoc sv_set_false
+
+Equivalent to C<sv_setsv(sv, &PL_sv_no)>, but may be made more
+efficient in the future. Doesn't handle set magic.
+
+The perl equivalent is C<$sv = !1;>.
+
+Introduced in perl 5.35.11.
+
+=cut
+*/
+
+void
+Perl_sv_set_false(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_SV_SET_FALSE;
+ sv_setsv(sv, &PL_sv_no);
+}
+
+/*
+=for apidoc sv_set_bool
+
+Equivalent to C<sv_setsv(sv, bool_val ? &Pl_sv_yes : &PL_sv_no)>, but
+may be made more efficient in the future. Doesn't handle set magic.
+
+The perl equivalent is C<$sv = !!$expr;>.
+
+Introduced in perl 5.35.11.
+
+=cut
+*/
+
+void
+Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
+{
+ PERL_ARGS_ASSERT_SV_SET_BOOL;
+ sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
+}
+
+
void
Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
{
}
/*
-=for apidoc sv_setpvn
-=for apidoc_item sv_setpvn_fresh
-=for apidoc_item sv_setpvn_mg
+=for apidoc sv_setpv
+=for apidoc_item sv_setpv_mg
+=for apidoc_item sv_setpvn
+=for apidoc_item sv_setpvn_fresh
+=for apidoc_item sv_setpvn_mg
+=for apidoc_item |void|sv_setpvs|SV* sv|"literal string"
+=for apidoc_item |void|sv_setpvs_mg|SV* sv|"literal string"
+
+These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.
+
+In the C<pvs> forms, the string must be a C literal string, enclosed in double
+quotes.
-These copy a string (possibly containing embedded C<NUL> characters) into an
-SV. The C<len> parameter indicates the number of bytes to be copied. If the
-C<ptr> argument is NULL the SV will become
+In the C<pvn> forms, the first byte of the string is pointed to by C<ptr>, and
+C<len> indicates the number of bytes to be copied, potentially including
+embedded C<NUL> characters.
+
+In the plain C<pv> forms, C<ptr> points to a NUL-terminated C string. That is,
+it points to the first byte of the string, and the copy proceeds up through the
+first enountered C<NUL> byte.
+
+In the forms that take a C<ptr> argument, if it is NULL, the SV will become
undefined.
The UTF-8 flag is not changed by these functions. A terminating NUL byte is
-guaranteed.
-
-They differ only in that:
+guaranteed in the result.
-C<sv_setpvn> does not handle 'set' magic; C<sv_setpvn_mg> does.
+The C<_mg> forms handle 'set' magic; the other forms skip all magic.
C<sv_setpvn_fresh> is a cut-down alternative to C<sv_setpvn>, intended ONLY
to be used with a fresh sv that has been upgraded to a SVt_PV, SVt_PVIV,
}
}
-/*
-=for apidoc sv_setpv
-=for apidoc_item sv_setpv_mg
-
-These copy a string into an SV. The string must be terminated with a C<NUL>
-character, and not contain embeded C<NUL>'s.
-
-They differ only in that:
-
-C<sv_setpv> does not handle 'set' magic; C<sv_setpv_mg> does.
-
-=cut
-*/
-
void
Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on(sv);
return;
- } else if (flags & HVhek_UNSHARED) {
+ } else if (flags & HVhek_NOTSHARED) {
sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
SvUTF8_on(sv);
/*
-=for apidoc sv_usepvn_flags
+=for apidoc sv_usepvn
+=for apidoc_item sv_usepvn_flags
+=for apidoc_item sv_usepvn_mg
+
+These tell an SV to use C<ptr> for its string value. Normally SVs have
+their string stored inside the SV, but these tell the SV to use an
+external string instead.
-Tells an SV to use C<ptr> to find its string value. Normally the
-string is stored inside the SV, but sv_usepvn allows the SV to use an
-outside string. C<ptr> should point to memory that was allocated
-by L<C<Newx>|perlclib/Memory Management and String Handling>. It must be
+C<ptr> should point to memory that was allocated
+by L</C<Newx>>. It must be
the start of a C<Newx>-ed block of memory, and not a pointer to the
middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
and not be from a non-C<Newx> memory allocator like C<malloc>. The
string length, C<len>, must be supplied. By default this function
-will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
-so that pointer should not be freed or used by the programmer after
-giving it to C<sv_usepvn>, and neither should any pointers from "behind"
-that pointer (e.g. ptr + 1) be used.
+will L</C<Renew>> (i.e. realloc, move) the memory pointed to by C<ptr>,
+so that the pointer should not be freed or used by the programmer after giving
+it to C<sv_usepvn>, and neither should any pointers from "behind" that pointer
+(I<e.g.>, S<C<ptr> + 1>) be used.
+
+In the C<sv_usepvn_flags> form, if S<C<flags & SV_SMAGIC>> is true,
+C<SvSETMAGIC> is called before returning.
+And if S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be
+C<NUL>, and the realloc will be skipped (I<i.e.>, the buffer is actually at
+least 1 byte longer than C<len>, and already meets the requirements for storing
+in C<SvPVX>).
+
+C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
+magic is skipped.
-If S<C<flags & SV_SMAGIC>> is true, will call C<SvSETMAGIC>. If
-S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be C<NUL>,
-and the realloc
-will be skipped (i.e. the buffer is actually at least 1 byte longer than
-C<len>, and already meets the requirements for storing in C<SvPVX>).
+C<sv_usepvn_mg> is merely C<sv_usepvn_flags> with C<flags> set to C<SV_SMAGIC>,
+so 'set' magic is performed.
=for apidoc Amnh||SV_SMAGIC
=for apidoc Amnh||SV_HAS_TRAILING_NUL
{
SV *sv;
- new_SV(sv);
- if (len) {
- sv_upgrade(sv, SVt_PV);
+ if (!len)
+ new_SV(sv);
+ else {
+ sv = newSV_type(SVt_PV);
sv_grow_fresh(sv, len + 1);
}
return sv;
}
}
- /* Force pos to be stored as characters, not bytes. */
- if (SvMAGICAL(sv) && DO_UTF8(sv)
- && (mg = mg_find(sv, PERL_MAGIC_regex_global))
- && mg->mg_len != -1
- && mg->mg_flags & MGf_BYTES) {
- mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
- SV_CONST_RETURN);
- mg->mg_flags &= ~MGf_BYTES;
- }
-
/* Rest of work is done else where */
mg = sv_magicext(sv,obj,how,vtable,name,namlen);
/* find slot to store array or singleton backref */
if (SvTYPE(sv) == SVt_PVHV) {
- if (SvOOK(sv)) {
+ if (HvHasAUX(sv)) {
struct xpvhv_aux * const iter = HvAUX((HV *)sv);
backrefs = (SV *)iter->xhv_backreferences;
}
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
if (SvTYPE(tsv) == SVt_PVHV) {
- if (SvOOK(tsv))
+ if (HvHasAUX(tsv))
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
U32 arena_index;
const struct body_details *sv_type_details;
- if (type == SVt_PVHV && SvOOK(sv)) {
+ if (type == SVt_PVHV && HvHasAUX(sv)) {
arena_index = HVAUX_ARENA_ROOT_IX;
sv_type_details = &fake_hv_with_aux;
}
CV* destructor = NULL;
struct mro_meta *meta;
- assert (SvOOK(stash));
+ assert (HvHasAUX(stash));
DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n",
HvNAME(stash)) );
Safefree(mg->mg_ptr);
s = SvPV_flags_const(sv, len, flags);
- if ((xf = _mem_collxfrm(s, len, &xlen, cBOOL(SvUTF8(sv))))) {
+ if ((xf = mem_collxfrm_(s, len, &xlen, cBOOL(SvUTF8(sv))))) {
if (! mg) {
mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
0, 0);
static char *
S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
- SV * const tsv = newSV(0);
+ SV * const tsv = newSV_type(SVt_NULL);
ENTER;
SAVEFREESV(tsv);
sv_gets(tsv, fp, 0);
/* All the flags we don't support must be zero.
And we're new code so I'm going to assert this from the start. */
assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
- new_SV(sv);
- sv_upgrade(sv, SVt_PV);
+ sv = newSV_type(SVt_PV);
sv_setpvn_fresh(sv,s,len);
/* This code used to do a sv_2mortal(), however we now unroll the call to
SV *
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
- SV *sv;
-
- new_SV(sv);
- sv_upgrade(sv, SVt_PV);
+ SV *sv = newSV_type(SVt_PV);
sv_setpvn_fresh(sv, s, len || s == NULL ? len : strlen(s));
return sv;
}
SV *
Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
- SV *sv;
- new_SV(sv);
- sv_upgrade(sv, SVt_PV);
+ SV *sv = newSV_type(SVt_PV);
sv_setpvn_fresh(sv,buffer,len);
return sv;
}
/*
+=for apidoc newSVhek_mortal
+
+Creates a new mortal SV from the hash key structure. It will generate
+scalars that point to the shared string table where possible. Returns
+a new (undefined) SV if C<hek> is NULL.
+
+This is more efficient than using sv_2mortal(newSVhek( ... ))
+
+=cut
+*/
+
+SV *
+Perl_newSVhek_mortal(pTHX_ const HEK *const hek)
+{
+ SV * const sv = newSVhek(hek);
+ assert(sv);
+ assert(!SvIMMORTAL(sv));
+
+ PUSH_EXTEND_MORTAL__SV_C(sv);
+ SvTEMP_on(sv);
+ return sv;
+}
+
+/*
=for apidoc newSVhek
Creates a new SV from the hash key structure. It will generate scalars that
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on (sv);
return sv;
- } else if (flags & HVhek_UNSHARED) {
+ } else if (flags & HVhek_NOTSHARED) {
/* A hash that isn't using shared hash keys has to have
the flag in every key so that we know not to try to call
share_hek_hek on it. */
{
/* Inline most of newSVpvn_share(), because share_hek_hek() is far
more efficient than sharepvn(). */
- SV *sv;
+ SV *sv = newSV_type(SVt_PV);
- new_SV(sv);
- sv_upgrade(sv, SVt_PV);
SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
}
if (!hash)
PERL_HASH(hash, src, len);
- new_SV(sv);
+ sv = newSV_type(SVt_PV);
/* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
changes here, update it there too. */
- sv_upgrade(sv, SVt_PV);
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
SvCUR_set(sv, len);
SvLEN_set(sv, 0);
SV *
Perl_newSVnv(pTHX_ const NV n)
{
- SV *sv;
+ SV *sv = newSV_type(SVt_NV);
+ (void)SvNOK_on(sv);
+
+ SvNV_set(sv, n);
+ SvTAINT(sv);
- new_SV(sv);
- sv_setnv(sv,n);
return sv;
}
SV *
Perl_newSViv(pTHX_ const IV i)
{
- SV *sv;
-
- new_SV(sv);
-
- /* Inlining ONLY the small relevant subset of sv_setiv here
- * for performance. Makes a significant difference. */
-
- /* We're starting from SVt_FIRST, so provided that's
- * actual 0, we don't have to unset any SV type flags
- * to promote to SVt_IV. */
- STATIC_ASSERT_STMT(SVt_FIRST == 0);
-
- SET_SVANY_FOR_BODYLESS_IV(sv);
- SvFLAGS(sv) |= SVt_IV;
+ SV *sv = newSV_type(SVt_IV);
(void)SvIOK_on(sv);
SvIV_set(sv, i);
}
/*
-=for apidoc newSV_type
+=for apidoc newSVbool
-Creates a new SV, of the type specified. The reference count for the new SV
-is set to 1.
+Creates a new SV boolean.
=cut
*/
SV *
-Perl_newSV_type(pTHX_ const svtype type)
+Perl_newSVbool(pTHX_ bool bool_val)
{
- SV *sv;
+ PERL_ARGS_ASSERT_NEWSVBOOL;
+ SV *sv = newSVsv(bool_val ? &PL_sv_yes : &PL_sv_no);
- new_SV(sv);
- ASSUME(SvTYPE(sv) == SVt_FIRST);
- if(type != SVt_FIRST)
- sv_upgrade(sv, type);
return sv;
}
/*
-=for apidoc newRV_noinc
+=for apidoc newSV_true
-Creates an RV wrapper for an SV. The reference count for the original
-SV is B<not> incremented.
+Creates a new SV that is a boolean true.
=cut
*/
-
SV *
-Perl_newRV_noinc(pTHX_ SV *const tmpRef)
+Perl_newSV_true(pTHX)
{
- SV *sv;
-
- PERL_ARGS_ASSERT_NEWRV_NOINC;
+ PERL_ARGS_ASSERT_NEWSV_TRUE;
+ SV *sv = newSVsv(&PL_sv_yes);
- new_SV(sv);
+ return sv;
+}
- /* We're starting from SVt_FIRST, so provided that's
- * actual 0, we don't have to unset any SV type flags
- * to promote to SVt_IV. */
- STATIC_ASSERT_STMT(SVt_FIRST == 0);
+/*
+=for apidoc newSV_false
- SET_SVANY_FOR_BODYLESS_IV(sv);
- SvFLAGS(sv) |= SVt_IV;
+Creates a new SV that is a boolean false.
- SvTEMP_off(tmpRef);
+=cut
+*/
- sv_setrv_noinc(sv, tmpRef);
+SV *
+Perl_newSV_false(pTHX)
+{
+ PERL_ARGS_ASSERT_NEWSV_FALSE;
+ SV *sv = newSVsv(&PL_sv_no);
return sv;
}
/*
=for apidoc newSVsv
-=for apidoc_item newSVsv_nomg
=for apidoc_item newSVsv_flags
+=for apidoc_item newSVsv_nomg
These create a new SV which is an exact duplicate of the original SV
(using C<sv_setsv>.)
if (!s) { /* reset ?? searches */
MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
- if (mg) {
+ if (mg && mg->mg_len) {
const U32 count = mg->mg_len / sizeof(PMOP**);
PMOP **pmp = (PMOP**) mg->mg_ptr;
PMOP *const *const end = pmp + count;
PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
sv_pvn_force(sv,lp);
- sv_utf8_downgrade(sv,0);
+ (void)sv_utf8_downgrade(sv,0);
*lp = SvCUR(sv);
return SvPVX(sv);
}
return FALSE;
}
-#ifndef NO_MATHOMS /* Can't move these to mathoms.c because call uiv_2buf(),
- private to this file */
-
-/*
-=for apidoc sv_setpviv
-=for apidoc_item sv_setpviv_mg
-
-These copy an integer into the given SV, also updating its string value.
-
-They differ only in that C<sv_setpviv_mg> performs 'set' magic; C<sv_setpviv>
-skips any magic.
-
-=cut
-*/
-
-void
-Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
-{
- /* The purpose of this union is to ensure that arr is aligned on
- a 2 byte boundary, because that is what uiv_2buf() requires */
- union {
- char arr[TYPE_CHARS(UV)];
- U16 dummy;
- } buf;
- char *ebuf;
- char * const ptr = uiv_2buf(buf.arr, iv, 0, 0, &ebuf);
-
- PERL_ARGS_ASSERT_SV_SETPVIV;
-
- sv_setpvn(sv, ptr, ebuf - ptr);
-}
-
-void
-Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
-{
- PERL_ARGS_ASSERT_SV_SETPVIV_MG;
-
- GCC_DIAG_IGNORE_STMT(-Wdeprecated-declarations);
-
- sv_setpviv(sv, iv);
-
- GCC_DIAG_RESTORE_STMT;
-
- SvSETMAGIC(sv);
-}
-
-#endif /* NO_MATHOMS */
-
#if defined(MULTIPLICITY)
/* pTHX_ magic can't cope with varargs, so this is a no-context
#endif
/*
-=for apidoc sv_setpvf
-=for apidoc_item sv_setpvf_nocontext
+=for apidoc sv_setpvf
=for apidoc_item sv_setpvf_mg
=for apidoc_item sv_setpvf_mg_nocontext
+=for apidoc_item sv_setpvf_nocontext
These work like C<L</sv_catpvf>> but copy the text into the SV instead of
appending it.
The differences between these are:
-C<sv_setpvf> and C<sv_setpvf_nocontext> do not handle 'set' magic;
-C<sv_setpvf_mg> and C<sv_setpvf_mg_nocontext> do.
+C<sv_setpvf_mg> and C<sv_setpvf_mg_nocontext> perform 'set' magic; C<sv_setpvf>
+and C<sv_setpvf_nocontext> skip all magic.
C<sv_setpvf_nocontext> and C<sv_setpvf_mg_nocontext> do not take a thread
context (C<aTHX>) parameter, so are used in situations where the caller
/*
=for apidoc sv_catpvf
-=for apidoc_item sv_catpvf_nocontext
=for apidoc_item sv_catpvf_mg
=for apidoc_item sv_catpvf_mg_nocontext
+=for apidoc_item sv_catpvf_nocontext
These process their arguments like C<sprintf>, and append the formatted
output to an SV. As with C<sv_vcatpvfn>, argument reordering is not supporte
Works like C<sv_vcatpvfn> but copies the text into the SV instead of
appending it.
-Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
+Usually used via one of its frontends L</C<sv_vsetpvf>> and
+L</C<sv_vsetpvf_mg>>.
=cut
*/
magic to handle or not handle; whereas plain C<sv_vcatpvfn> always specifies
both 'get' and 'set' magic.
-They are usually used via one of the frontends C<sv_vcatpvf> and
-C<sv_vcatpvf_mg>.
+They are usually used via one of the frontends L</C<sv_vcatpvf>> and
+L</C<sv_vcatpvf_mg>>.
=cut
*/
#endif
/* we never change this unless USE_LOCALE_NUMERIC */
bool in_lc_numeric = FALSE;
+ SV *tmp_sv = NULL;
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
char c; /* the actual format ('d', s' etc) */
+ bool escape_it = FALSE; /* if this is a string should we quote and escape it? */
+
/* echo everything up to the next format specification */
for (q = fmtstart; q < patend && *q != '%'; ++q)
}
string:
+ if (escape_it) {
+ U32 flags = PERL_PV_PRETTY_QUOTEDPREFIX;
+ if (is_utf8)
+ flags |= PERL_PV_ESCAPE_UNI;
+
+ if (!tmp_sv) {
+ /* "blah"... where blah might be made up
+ * of characters like \x{1234} */
+ tmp_sv = newSV(1 + (PERL_QUOTEDPREFIX_LEN * 8) + 1 + 3);
+ sv_2mortal(tmp_sv);
+ }
+ pv_pretty(tmp_sv, eptr, elen, PERL_QUOTEDPREFIX_LEN,
+ NULL, NULL, flags);
+ eptr = SvPV_const(tmp_sv, elen);
+ }
if (has_precis && precis < elen)
elen = precis;
break;
case 'p':
- /* %p extensions:
+ /* BEGIN NOTE
+ *
+ * We want to extend the C level sprintf format API with
+ * custom formats for specific types (eg SV*) and behavior.
+ * However some C compilers are "sprintf aware" and will
+ * throw compile time exceptions when an illegal sprintf is
+ * encountered, so we can't just add new format letters.
+ *
+ * However it turns out the length argument to the %p format
+ * is more or less useless (the size of a pointer does not
+ * change over time) and is not really used in the C level
+ * code. Accordingly we can map our special behavior to
+ * specific "length" options to the %p format. We hide these
+ * mappings behind defines anyway, so nobody needs to know
+ * that HEKf is actually %2p. This keeps the C compiler
+ * happy while allowing us to add new formats.
+ *
+ * Note the existing logic for which number is used for what
+ * is torturous. All negative values are used for SVf, and
+ * non-negative values have arbitrary meanings with no
+ * structure to them. This may change in the future.
+ *
+ * NEVER use the raw %p values directly. Always use the define
+ * as the underlying mapping may change in the future.
+ *
+ * END NOTE
+ *
+ * %p extensions:
*
* "%...p" is normally treated like "%...x", except that the
* number to print is the SV's address (or a pointer address
* extensions. These are currently:
*
* %-p (SVf) Like %s, but gets the string from an SV*
- * arg rather than a char* arg.
+ * arg rather than a char* arg. Use C<SVfARG()>
+ * to set up the argument properly.
* (This was previously %_).
*
- * %-<num>p Ditto but like %.<num>s (i.e. num is max width)
+ * %-<num>p Ditto but like %.<num>s (i.e. num is max
+ * width), there is no escaped and quoted version
+ * of this.
+ *
+ * %1p (PVf_QUOTEDPREFIX). Like raw %s, but it is escaped
+ * and quoted.
+ *
+ * %5p (SVf_QUOTEDPREFIX) Like SVf, but length restricted,
+ * escaped and quoted with pv_pretty. Intended
+ * for error messages.
*
* %2p (HEKf) Like %s, but using the key string in a HEK
+ * %7p (HEKf_QUOTEDPREFIX) ... but escaped and quoted.
*
* %3p (HEKf256) Ditto but like %.256s
+ * %8p (HEKf256_QUOTEDPREFIX) ... but escaped and quoted
*
* %d%lu%4p (UTF8f) A utf8 string. Consumes 3 args:
* (cBOOL(utf8), len, string_buf).
* It's handled by the "case 'd'" branch
* rather than here.
+ * %d%lu%9p (UTF8f_QUOTEDPREFIX) .. but escaped and quoted.
+ *
*
- * %<num>p where num is 1 or > 4: reserved for future
+ * %<num>p where num is > 9: reserved for future
* extensions. Warns, but then is treated as a
* general %p (print hex address) format.
+ *
+ * NOTE: If you add a new magic %p value you will
+ * need to update F<t/porting/diag.t> to be aware of it
+ * on top of adding the various defines and etc. Do not
+ * forget to add it to F<pod/perlguts.pod> as well.
*/
if ( args
&& q[-2] != '*'
&& q[-2] != '$'
) {
- if (left) { /* %-p (SVf), %-NNNp */
- if (width) {
+ if (left || width == 5) { /* %-p (SVf), %-NNNp, %5p */
+ if (left && width) {
precis = width;
has_precis = TRUE;
+ } else if (width == 5) {
+ escape_it = TRUE;
}
argsv = MUTABLE_SV(va_arg(*args, void*));
eptr = SvPV_const(argsv, elen);
width = 0;
goto string;
}
- else if (width == 2 || width == 3) { /* HEKf, HEKf256 */
+ else if (width == 2 || width == 3 ||
+ width == 7 || width == 8)
+ { /* HEKf, HEKf256, HEKf_QUOTEDPREFIX, HEKf256_QUOTEDPREFIX */
HEK * const hek = va_arg(*args, HEK *);
eptr = HEK_KEY(hek);
elen = HEK_LEN(hek);
precis = 256;
has_precis = TRUE;
}
+ if (width > 5)
+ escape_it = TRUE;
+ width = 0;
+ goto string;
+ }
+ else if (width == 1) {
+ eptr = va_arg(*args,char *);
+ elen = strlen(eptr);
+ escape_it = TRUE;
width = 0;
goto string;
}
else if (width) {
+ /* note width=4 or width=9 is handled under %d */
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
"internal %%<num>p might conflict with future printf extensions");
}
case 'd':
/* probably just a plain %d, but it might be the start of the
* special UTF8f format, which usually looks something like
- * "%d%lu%4p" (the lu may vary by platform)
+ * "%d%lu%4p" (the lu may vary by platform) or
+ * "%d%lu%9p" for an escaped version.
*/
assert((UTF8f)[0] == 'd');
assert((UTF8f)[1] == '%');
&& q == fmtstart + 1 /* plain %d, not %....d */
&& patend >= fmtstart + sizeof(UTF8f) - 1 /* long enough */
&& *q == '%'
- && strnEQ(q + 1, (UTF8f) + 2, sizeof(UTF8f) - 3))
+ && strnEQ(q + 1, (UTF8f) + 2, sizeof(UTF8f) - 5)
+ && q[sizeof(UTF8f)-3] == 'p'
+ && (q[sizeof(UTF8f)-4] == '4' ||
+ q[sizeof(UTF8f)-4] == '9'))
{
/* The argument has already gone through cBOOL, so the cast
is safe. */
+ if (q[sizeof(UTF8f)-4] == '9')
+ escape_it = TRUE;
is_utf8 = (bool)va_arg(*args, int);
elen = va_arg(*args, UV);
/* if utf8 length is larger than 0x7ffff..., then it might
return parser;
}
+/*
+=for apidoc_section $io
+=for apidoc fp_dup
+
+Duplicate a file handle, returning a pointer to the cloned object.
-/* duplicate a file handle */
+=cut
+*/
PerlIO *
Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
return ret;
}
-/* duplicate a directory handle */
+/*
+=for apidoc_section $io
+=for apidoc dirp_dup
+
+Duplicate a directory handle, returning a pointer to the cloned object.
+
+=cut
+*/
DIR *
Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
return ret;
}
-/* duplicate a typeglob */
+/*
+=for apidoc_section $GV
+=for apidoc gp_dup
+
+Duplicate a typeglob, returning a pointer to the cloned object.
+
+=cut
+*/
GP *
Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
return ret;
}
-/* duplicate a chain of magic */
+
+/*
+=for apidoc_section $magic
+=for apidoc mg_dup
+
+Duplicate a chain of magic, returning a pointer to the cloned object.
+
+=cut
+*/
MAGIC *
Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
};
-/* create a new pointer-mapping table */
+/*
+=for apidoc ptr_table_new
+
+Create a new pointer-mapping table
+
+=cut
+*/
PTR_TBL_t *
Perl_ptr_table_new(pTHX)
return NULL;
}
+/*
+=for apidoc ptr_table_fetch
+
+Look for C<sv> in the pointer-mapping table C<tbl>, returning its value, or
+NULL if not found.
+
+=cut
+*/
+
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
{
return tblent ? tblent->newval : NULL;
}
-/* add a new entry to a pointer-mapping table 'tbl'. In hash terms, 'oldsv' is
- * the key; 'newsv' is the value. The names "old" and "new" are specific to
- * the core's typical use of ptr_tables in thread cloning. */
+/*
+=for apidoc ptr_table_store
+
+Add a new entry to a pointer-mapping table C<tbl>.
+In hash terms, C<oldsv> is the key; Cnewsv> is the value.
+
+The names "old" and "new" are specific to the core's typical use of ptr_tables
+in thread cloning.
+
+=cut
+*/
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
}
}
-/* double the hash bucket size of an existing ptr table */
+/*
+=for apidoc ptr_table_split
+
+Double the hash bucket size of an existing ptr table
+
+=cut
+*/
void
Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
}
}
-/* clear and free a ptr table */
+/*
+=for apidoc ptr_table_free
+
+Clear and free a ptr table
+
+=cut
+*/
void
Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
break;
case SVt_PVHV:
- if (SvOOK(ssv)) {
+ if (HvHasAUX(ssv)) {
sv_type_details = &fake_hv_with_aux;
#ifdef PURIFY
new_body = new_NOARENA(sv_type_details);
if (LvTYPE(dsv) == 't') /* for tie: unrefcnted fake (SV**) */
LvTARG(dsv) = dsv;
else if (LvTYPE(dsv) == 'T') /* for tie: fake HE */
- LvTARG(dsv) = MUTABLE_SV(he_dup((HE*)LvTARG(dsv), 0, param));
+ LvTARG(dsv) = MUTABLE_SV(he_dup((HE*)LvTARG(dsv), FALSE, param));
else
LvTARG(dsv) = sv_dup_inc(LvTARG(dsv), param);
if (isREGEXP(ssv)) goto duprex;
case SVt_PVHV:
if (HvARRAY((const HV *)ssv)) {
STRLEN i = 0;
- const bool sharekeys = !!HvSHAREKEYS(ssv);
XPVHV * const dxhv = (XPVHV*)SvANY(dsv);
XPVHV * const sxhv = (XPVHV*)SvANY(ssv);
char *darray;
while (i <= sxhv->xhv_max) {
const HE * const source = HvARRAY(ssv)[i];
HvARRAY(dsv)[i] = source
- ? he_dup(source, sharekeys, param) : 0;
+ ? he_dup(source, FALSE, param) : 0;
++i;
}
- if (SvOOK(ssv)) {
+ if (HvHasAUX(ssv)) {
const struct xpvhv_aux * const saux = HvAUX(ssv);
struct xpvhv_aux * const daux = HvAUX(dsv);
/* This flag isn't copied. */
#endif
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
- ? he_dup(saux->xhv_eiter,
- cBOOL(HvSHAREKEYS(ssv)), param) : 0;
+ ? he_dup(saux->xhv_eiter, FALSE, param) : 0;
/* backref array needs refcnt=2; see sv_add_backref */
daux->xhv_backreferences =
(param->flags & CLONEf_JOIN_IN)
} else if (CvCONST(dsv)) {
CvXSUBANY(dsv).any_ptr =
sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param);
+ } else if (CvREFCOUNTED_ANYSV(dsv)) {
+ CvXSUBANY(dsv).any_sv =
+ sv_dup_inc((const SV *)CvXSUBANY(dsv).any_sv, param);
}
assert(!CvSLABBED(dsv));
if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv));
return ncxs;
}
-/* duplicate a stack info structure */
+/*
+=for apidoc si_dup
+
+Duplicate a stack info structure, returning a pointer to the cloned object.
+
+=cut
+*/
PERL_SI *
Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
return ret;
}
-/* duplicate the save stack */
+/*
+=for apidoc ss_dup
+
+Duplicate the save stack, returning a pointer to the cloned object.
+
+=cut
+*/
ANY *
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
PL_savestack_max = -1;
PL_sig_pending = 0;
PL_parser = NULL;
+ PL_eval_begin_nest_depth = proto_perl->Ieval_begin_nest_depth;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
Zero(&PL_padname_undef, 1, PADNAME);
Zero(&PL_padname_const, 1, PADNAME);
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
PL_evalseq = proto_perl->Ievalseq;
- PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
PL_origalen = proto_perl->Iorigalen;
PL_sighandlerp = proto_perl->Isighandlerp;
PL_collxfrm_base = proto_perl->Icollxfrm_base;
PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
PL_strxfrm_max_cp = proto_perl->Istrxfrm_max_cp;
+ PL_strxfrm_is_behaved = proto_perl->Istrxfrm_is_behaved;
+ PL_strxfrm_NUL_replacement = proto_perl->Istrxfrm_NUL_replacement;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
/* Did the locale setup indicate UTF-8? */
PL_utf8locale = proto_perl->Iutf8locale;
- PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
- PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale;
- my_strlcpy(PL_locale_utf8ness, proto_perl->Ilocale_utf8ness, sizeof(PL_locale_utf8ness));
-#if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
- PL_lc_numeric_mutex_depth = 0;
+
+#ifdef USE_LOCALE_THREADS
+ assert(PL_locale_mutex_depth <= 0);
+ PL_locale_mutex_depth = 0;
#endif
/* Unicode features (see perlrun/-C) */
PL_unicode = proto_perl->Iunicode;
PL_srand_called = proto_perl->Isrand_called;
Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
+ PL_srand_override = proto_perl->Isrand_override;
+ PL_srand_override_next = proto_perl->Isrand_override_next;
if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
-#if defined(USE_POSIX_2008_LOCALE) \
- && defined(USE_THREAD_SAFE_LOCALE) \
- && ! defined(HAS_QUERYLOCALE)
+#ifdef USE_PL_CURLOCALES
for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
- PL_curlocales[i] = savepv("."); /* An illegal value */
+ PL_curlocales[i] = SAVEPV(proto_perl->Icurlocales[i]);
}
#endif
#ifdef USE_LOCALE_CTYPE
+ Copy(proto_perl->Ifold_locale, PL_fold_locale, 256, U8);
/* Should we warn if uses locale? */
+ PL_ctype_name = SAVEPV(proto_perl->Ictype_name);
PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param);
+ PL_utf8locale = proto_perl->Iutf8locale;
+ PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
+ PL_in_utf8_turkic_locale = proto_perl->Iin_utf8_turkic_locale;
#endif
#ifdef USE_LOCALE_COLLATE
+ PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale;
PL_collation_name = SAVEPV(proto_perl->Icollation_name);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
+ PL_underlying_radix_sv = sv_dup_inc(proto_perl->Iunderlying_radix_sv, param);
-# if defined(HAS_POSIX_2008_LOCALE)
+# if defined(USE_POSIX_2008_LOCALE)
PL_underlying_numeric_obj = NULL;
# endif
#endif /* !USE_LOCALE_NUMERIC */
+#if defined(USE_POSIX_2008_LOCALE)
+ PL_scratch_locale_obj = NULL;
+#endif
#ifdef HAS_MBRLEN
PL_mbrlen_ps = proto_perl->Imbrlen_ps;
PL_setlocale_buf = NULL;
PL_setlocale_bufsize = 0;
+ PL_stdize_locale_buf = NULL;
+ PL_stdize_locale_bufsize = 0;
+
/* Unicode inversion lists */
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
for (i = 0; i < POSIX_CC_COUNT; i++) {
PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
- if (i != _CC_CASED && i != _CC_VERTSPACE) {
+ if (i != CC_CASED_ && i != CC_VERTSPACE_) {
PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
}
}
- PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA];
- PL_Posix_ptrs[_CC_VERTSPACE] = NULL;
+ PL_Posix_ptrs[CC_CASED_] = PL_Posix_ptrs[CC_ALPHA_];
+ PL_Posix_ptrs[CC_VERTSPACE_] = NULL;
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
If C<sv> already is UTF-8 (or if it is not C<POK>), or if C<encoding>
is not a reference, nothing is done to C<sv>. If C<encoding> is not
an C<Encode::XS> Encoding object, bad things will happen.
-(See F<cpan/Encode/encoding.pm> and L<Encode>.)
+(See L<encoding> and L<Encode>.)
The PV of C<sv> is returned.
HE *entry;
for (entry = array[i]; entry; entry = HeNEXT(entry)) {
if (HeVAL(entry) == val)
- return sv_2mortal(newSVhek(HeKEY_hek(entry)));
+ return newSVhek_mortal(HeKEY_hek(entry));
}
}
return NULL;
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
- SV * const sv = newSV(0);
+ SV * const sv = newSV_type(SVt_NULL);
STRLEN len;
const char * const pv = SvPV_nomg_const((SV*)keyname, len);
/*
+=for apidoc_section $warning
=for apidoc report_uninit
Print appropriate "Use of uninitialized variable" warning.
https://perl5.git.perl.org / perl5.git / blobdiff