#ifdef DEBUG_LEAKING_SCALARS
# define FREE_SV_DEBUG_FILE(sv) STMT_START { \
- if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
+ if ((sv)->sv_debug_file) { \
+ PerlMemShared_free((sv)->sv_debug_file); \
+ sv->sv_debug_file = NULL; \
+ } \
} STMT_END
# define DEBUG_SV_SERIAL(sv) \
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) del_SV\n", \
/* visit(): call the named function for each non-free SV in the arenas
* whose flags field matches the flags/mask args. */
-STATIC I32
+STATIC SSize_t
S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
{
SV* sva;
const SV * const svend = &sva[SvREFCNT(sva)];
SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != (svtype)SVTYPEMASK
+ if (!SvIS_FREED(sv)
&& (sv->sv_flags & mask) == flags
&& SvREFCNT(sv))
{
static void
do_report_used(pTHX_ SV *const sv)
{
- if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
+ if (!SvIS_FREED(sv)) {
PerlIO_printf(Perl_debug_log, "****\n");
sv_dump(sv);
}
=cut
*/
-I32
+SSize_t
Perl_sv_clean_all(pTHX)
{
- I32 cleaned;
+ SSize_t cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
return cleaned;
}
+
+#ifdef DEBUGGING
+
+/* Called by sv_mark_arenas() for each live SV: set SVf_BREAK */
+
+static void
+S_do_sv_mark_arenas(pTHX_ SV *const sv)
+{
+ sv->sv_flags |= SVf_BREAK;
+}
+
+/* sv_mark_arenas(): for leak debugging: mark all live SVs with SVf_BREAK.
+ * Then later, use sv_sweep_arenas() to list any SVs not so marked.
+ */
+
+void
+Perl_sv_mark_arenas(pTHX)
+{
+ visit(S_do_sv_mark_arenas, 0, 0);
+}
+
+/* Called by sv_sweep_arenas() for each live SV, to list any SVs without
+ * SVf_BREAK set */
+
+static void
+S_do_sv_sweep_arenas(pTHX_ SV *const sv)
+{
+ if (sv->sv_flags & SVf_BREAK) {
+ sv->sv_flags &= ~SVf_BREAK;
+ return;
+ }
+ PerlIO_printf(Perl_debug_log, "Unmarked SV: 0x%p: %s\n",
+ sv, SvPEEK(sv));
+}
+
+
+/* sv_sweep_arenas(): for debugging: list all live SVs that don't have
+ * SVf_BREAK set, then turn off all SVf_BREAK flags. Typically used some
+ * time after sv_mark_arenas(), to find SVs which have been created since
+ * the marking but not yet freed (they may have leaked, or been stored in
+ * an array, or whatever).
+ */
+
+void
+Perl_sv_sweep_arenas(pTHX)
+{
+ visit(S_do_sv_sweep_arenas, 0, 0);
+}
+
+#endif
+
+
/*
ARENASETS: a meta-arena implementation which separates arena-info
into struct arena_set, which contains an array of struct
/*
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
+ routines and related definitions remain here, but others were
moved into sv_inline.h to facilitate inlining of newSV_type().
There are 4 kinds of arenas:
Arena types 2 & 3 are chained by body-type off an array of
arena-root pointers, which is indexed by svtype. Some of the
larger/less used body types are malloced singly, since a large
- unused block of them is wasteful. Also, several svtypes dont have
+ unused block of them is wasteful. Also, several svtypes don't have
bodies; the data fits into the sv-head itself. The arena-root
pointer thus has a few unused root-pointers (which may be hijacked
later for arena type 4)
return;
case SVt_PVHV:
case SVt_PVAV:
+ case SVt_PVOBJ:
assert(new_type_details->body_size);
#ifndef PURIFY
new_body = new_NOARENAZ(new_type_details);
#endif
SvANY(sv) = new_body;
- if (new_type == SVt_PVAV) {
- *((XPVAV*) SvANY(sv)) = (XPVAV) {
- .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
- .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
+ switch(new_type) {
+ case SVt_PVAV:
+ {
+ XPVAV pvav = {
+ .xmg_stash = NULL,
+ .xmg_u = {.xmg_magic = NULL},
+ .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
};
+ *((XPVAV*) SvANY(sv)) = pvav;
+ }
AvREAL_only(sv);
- } else {
- *((XPVHV*) SvANY(sv)) = (XPVHV) {
- .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
- .xhv_keys = 0,
- /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
- .xhv_max = PERL_HASH_DEFAULT_HvMAX
+ break;
+ case SVt_PVHV:
+ {
+ XPVHV pvhv = {
+ .xmg_stash = NULL,
+ .xmg_u = {.xmg_magic = NULL},
+ .xhv_keys = 0,
+ /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
+ .xhv_max = PERL_HASH_DEFAULT_HvMAX
};
+ *((XPVHV*) SvANY(sv)) = pvhv;
+ }
assert(!SvOK(sv));
SvOK_off(sv);
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(sv); /* key-sharing on by default */
#endif
+ break;
+ case SVt_PVOBJ:
+ {
+ XPVOBJ pvo = {
+ .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
+ .xobject_maxfield = -1,
+ .xobject_iter_sv_at = 0,
+ .xobject_fields = NULL,
+ };
+ *((XPVOBJ*) SvANY(sv)) = pvo;
+ }
+ break;
+ default:
+ NOT_REACHED;
}
/* SVt_NULL isn't the only thing upgraded to AV or HV.
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);
}
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
- minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
+ minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + PERL_STRLEN_NEW_MIN;
if (newlen < minlen)
newlen = minlen;
#ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
newlen++;
#endif
- /* 10 is a longstanding, hardcoded minimum length in sv_grow. */
- /* Just doing the same here for consistency. */
- if (newlen < 10)
- newlen = 10;
+ if (newlen < PERL_STRLEN_NEW_MIN)
+ newlen = PERL_STRLEN_NEW_MIN;
s = (char*)safemalloc(newlen);
SvPV_set(sv, s);
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
+#if NVSIZE <= IVSIZE
+ case SVt_NULL:
+ case SVt_NV:
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= SVt_IV;
+ break;
+#else
case SVt_NULL:
+ SET_SVANY_FOR_BODYLESS_IV(sv);
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= SVt_IV;
+ break;
case SVt_NV:
sv_upgrade(sv, SVt_IV);
break;
+#endif
case SVt_PV:
sv_upgrade(sv, SVt_PVIV);
break;
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
+#if NVSIZE <= IVSIZE
+ SET_SVANY_FOR_BODYLESS_NV(sv);
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= SVt_NV;
+ break;
+#else
sv_upgrade(sv, SVt_NV);
break;
+#endif
case SVt_PV:
case SVt_PVIV:
sv_upgrade(sv, SVt_PVNV);
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.
/* 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.
Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
{
char *s;
+ bool done_gmagic = FALSE;
PERL_ARGS_ASSERT_SV_2PV_FLAGS;
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
&& SvTYPE(sv) != SVt_PVFM);
- if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) {
mg_get(sv);
+ done_gmagic = TRUE;
+ }
+
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SV *tmpstr;
+ SV *nsv= (SV *)sv;
if (flags & SV_SKIP_OVERLOAD)
return NULL;
- tmpstr = AMG_CALLunary(sv, string_amg);
+ if (done_gmagic)
+ nsv = sv_mortalcopy_flags(sv,0);
+ tmpstr = AMG_CALLunary(nsv, string_amg);
TAINT_IF(tmpstr && SvTAINTED(tmpstr));
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(nsv)))) {
/* Unwrap this: */
/* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
*/
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
/*
=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.
/* adjust pos to the start of a UTF8 char sequence */
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg) {
- I32 pos = mg->mg_len;
+ SSize_t pos = mg->mg_len;
if (pos > 0) {
for (c = start + pos; c > start; c--) {
if (UTF8_IS_START(*c))
/* If source has a real method, then a method is
going to change */
else if(
- GvCV((const GV *)ssv) && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
+ GvCV((const GV *)ssv) && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
) {
mro_changes = 1;
}
/* If dest already had a real method, that's a change as well */
if(
!mro_changes && GvGP(MUTABLE_GV(dsv)) && GvCVu((const GV *)dsv)
- && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
+ && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
) {
mro_changes = 1;
}
if(memEQs(name, len, "ISA")
/* The stash may have been detached from the symbol table, so
check its name. */
- && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
+ && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
)
mro_changes = 2;
else {
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);
}
}
else if(mro_changes == 3) {
HV * const stash = GvHV(dsv);
- if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
+ if(old_stash ? HvHasENAME(old_stash) : cBOOL(stash))
mro_package_moved(
stash, old_stash,
(GV *)dsv, 0
{
SV * const new_const_sv =
CvCONST((const CV *)sref)
- ? cv_const_sv((const CV *)sref)
+ ? cv_const_sv_or_av((const CV *)sref)
: NULL;
HV * const stash = GvSTASH((const GV *)dsv);
report_redefined_cv(
(len > 1 && name[len-2] == ':' && name[len-1] == ':')
|| (len == 1 && name[0] == ':')
)
- && (!dref || HvENAME_get(dref))
+ && (!dref || HvHasENAME(dref))
) {
mro_package_moved(
(HV *)sref, (HV *)dref,
&& memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA")
/* The stash may have been detached from the symbol table, so
check its name before doing anything. */
- && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
+ && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
) {
MAGIC *mg;
MAGIC * const omg = dref && SvSMAGICAL(dref)
: 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) {
* freed) just by testing the or'ed types */
STATIC_ASSERT_STMT(SVt_NULL == 0);
STATIC_ASSERT_STMT(SVt_IV == 1);
+ STATIC_ASSERT_STMT(SVt_NV == 2);
+#if NVSIZE <= IVSIZE
+ if (both_type <= 2) {
+#else
if (both_type <= 1) {
- /* both src and dst are UNDEF/IV/RV, so we can do a lot of
- * special-casing */
+#endif
+ /* both src and dst are UNDEF/IV/RV - maybe NV depending on config,
+ * so we can do a lot of special-casing */
U32 sflags;
U32 new_dflags;
SV *old_rv = NULL;
sv_unref_flags(dsv, 0);
else
old_rv = SvRV(dsv);
+ SvROK_off(dsv);
}
assert(!SvGMAGICAL(ssv));
new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
}
}
+#if NVSIZE <= IVSIZE
+ else if (sflags & SVf_NOK) {
+ SET_SVANY_FOR_BODYLESS_NV(dsv);
+ new_dflags = (SVt_NV|SVf_NOK|SVp_NOK);
+
+ /* both src and dst are <= SVt_MV, so sv_any points to the
+ * head; so access the head directly
+ */
+ assert( &(ssv->sv_u.svu_nv)
+ == &(((XPVNV*) SvANY(ssv))->xnv_u.xnv_nv));
+ assert( &(dsv->sv_u.svu_nv)
+ == &(((XPVNV*) SvANY(dsv))->xnv_u.xnv_nv));
+ dsv->sv_u.svu_nv = ssv->sv_u.svu_nv;
+ }
+#endif
else {
new_dflags = dtype; /* turn off everything except the type */
}
- SvFLAGS(dsv) = new_dflags;
- SvREFCNT_dec(old_rv);
+ /* Should preserve some dsv flags - at least SVs_TEMP, */
+ /* so cannot just set SvFLAGS(dsv) = new_dflags */
+ /* First clear the flags that we do want to clobber */
+ (void)SvOK_off(dsv);
+ SvFLAGS(dsv) &= ~SVTYPEMASK;
+ /* Now set the new flags */
+ SvFLAGS(dsv) |= new_dflags;
+ SvREFCNT_dec(old_rv);
return;
}
SV_CHECK_THINKFIRST_COW_DROP(dsv);
dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */
- /* There's a lot of redundancy below but we're going for speed here */
+ /* There's a lot of redundancy below but we're going for speed here
+ * Note: some of the cases below do return; rather than break; so the
+ * if-elseif-else logic below this switch does not see all cases. */
switch (stype) {
case SVt_NULL:
case SVt_INVLIST:
invlist_clone(ssv, dsv);
- break;
+ return;
default:
{
const char * const type = sv_reftype(ssv,0);
if (reset_isa) {
HV * const stash = GvHV(dsv);
if(
- old_stash ? (HV *)HvENAME_get(old_stash) : stash
+ old_stash ? HvHasENAME(old_stash) : cBOOL(stash)
)
mro_package_moved(
stash, old_stash,
* be allocated it is still not worth swiping PADTMPs for short
* strings, as the savings here are small.
*
- * If swiping is not an option, then we see whether it is
- * worth using copy-on-write. If the lhs already has a buf-
- * fer big enough and the string is short, we skip it and fall back
- * to method 3, since memcpy is faster for short strings than the
- * later bookkeeping overhead that copy-on-write entails.
+ * If swiping is not an option, then we see whether it is worth using
+ * copy-on-write. If the lhs already has a buffer big enough and the
+ * string is short, we skip it and fall back to method 3, since memcpy
+ * is faster for short strings than the later bookkeeping overhead that
+ * copy-on-write entails.
* If the rhs is not a copy-on-write string yet, then we also
* consider whether the buffer is too large relative to the string
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)
{
sv_force_normal_flags(dsv, SV_COW_DROP_PV);
else if (SvPVX_const(dsv))
Safefree(SvPVX_mutable(dsv));
+ SvUPGRADE(dsv, SVt_COW);
}
else
- new_SV(dsv);
- SvUPGRADE(dsv, SVt_COW);
+ dsv = newSV_type(SVt_COW);
assert (SvPOK(ssv));
assert (SvPOKp(ssv));
}
/*
-=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 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"
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.
+first encountered C<NUL> byte.
In the forms that take a C<ptr> argument, if it is NULL, the SV will become
undefined.
/*
=for apidoc sv_usepvn
-=for apidoc_item sv_usepvn_mg
=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
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY) {
/* Yes, this is casting away const. This is only for the case of
- HEf_SVKEY. I think we need to document this aberation of the
+ HEf_SVKEY. I think we need to document this aberration of the
constness of the API, rather than making name non-const, as
that change propagating outwards a long way. */
mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
}
}
- /* 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);
}
static int
-S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
+S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl, const U32 flags)
{
MAGIC* mg;
MAGIC** mgp;
*/
int
-Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl)
{
PERL_ARGS_ASSERT_SV_UNMAGICEXT;
return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
/* 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) {
- /* It's possible for the the last (strong) reference to tsv to have
+ /* It's possible for the last (strong) reference to tsv to have
become freed *before* the last thing holding a weak reference.
If both survive longer than the backreferences array, then when
the referent's reference count drops to 0 and it is freed, it's
}
/*
-=for apidoc sv_insert
-
-Inserts and/or replaces a string at the specified offset/length within the SV.
-Similar to the Perl C<substr()> function, with C<littlelen> bytes starting at
-C<little> replacing C<len> bytes of the string in C<bigstr> starting at
-C<offset>. Handles get magic.
+=for apidoc sv_insert
+=for apidoc_item sv_insert_flags
-=for apidoc sv_insert_flags
+These insert and/or replace a string at the specified offset/length within the
+SV. Similar to the Perl C<substr()> function, with C<littlelen> bytes starting
+at C<little> replacing C<len> bytes of the string in C<bigstr> starting at
+C<offset>. They handle get magic.
-Same as C<sv_insert>, but the extra C<flags> are passed to the
-C<SvPV_force_flags> that applies to C<bigstr>.
+C<sv_insert_flags> is identical to plain C<sv_insert>, but the extra C<flags>
+are passed to the C<SvPV_force_flags> operation that is internally applied to
+C<bigstr>.
=cut
*/
}
/* if not, anonymise: */
- gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
+ gvname = (GvSTASH(gv) && HvHasNAME(GvSTASH(gv)) && HvHasENAME(GvSTASH(gv)))
? newSVhek(HvENAME_HEK(GvSTASH(gv)))
: newSVpvn_flags( "__ANON__", 8, 0 );
sv_catpvs(gvname, "::__ANON__");
its type is set to all 1's so that it won't inadvertently be assumed
to be live during global destruction etc.
This function should only be called when C<REFCNT> is zero. Most of the time
-you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
-instead.
+you'll want to call C<SvREFCNT_dec> instead.
=cut
*/
HV *stash;
assert(SvREFCNT(sv) == 0);
- assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
-
+ assert(!SvIS_FREED(sv));
+#if NVSIZE <= IVSIZE
+ if (type <= SVt_NV) {
+#else
if (type <= SVt_IV) {
+#endif
/* Historically this check on type was needed so that the code to
* free bodies wasn't reached for these types, because the arena
* slots were re-used for HEs and pointer table entries. The
* path, as SvPVX() doesn't point to valid memory.
*
* Hence this code is still the most efficient way to handle this.
+ *
+ * Additionally, for bodyless NVs, riding this branch is more
+ * efficient than stepping through the general logic.
*/
if (SvROK(sv))
}
break;
+ case SVt_PVOBJ:
+ if(ObjectMAXFIELD(sv) > -1) {
+ next_sv = ObjectFIELDS(sv)[ObjectMAXFIELD(sv)--];
+ /* save old iter_sv in top-most field, and pray that it
+ * doesn't get wiped in the meantime */
+ ObjectFIELDS(sv)[(ObjectITERSVAT(sv) = ObjectMAXFIELD(sv) + 1)] = iter_sv;
+ iter_sv = sv;
+ goto get_next_sv;
+ }
+ Safefree(ObjectFIELDS(sv));
+ break;
case SVt_PVLV:
if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
- && HvENAME_get(stash))
+ && HvHasENAME(stash))
mro_method_changed_in(stash);
gp_free(MUTABLE_GV(sv));
if (GvNAME_HEK(sv))
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;
}
Safefree(AvALLOC(av));
goto free_body;
}
+ } else if (SvTYPE(iter_sv) == SVt_PVOBJ) {
+ if (ObjectMAXFIELD(iter_sv) > -1) {
+ sv = ObjectFIELDS(iter_sv)[ObjectMAXFIELD(iter_sv)--];
+ }
+ else { /* no more fields in the current SV to free */
+ sv = iter_sv;
+ type = SvTYPE(sv);
+ iter_sv = ObjectFIELDS(sv)[ObjectITERSVAT(sv)];
+ Safefree(ObjectFIELDS(sv));
+ goto free_body;
+ }
} else if (SvTYPE(iter_sv) == SVt_PVHV) {
sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
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)) );
PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
if (uoffset < 2 * backw) {
- /* The assumption is that going forwards is twice the speed of going
- forward (that's where the 2 * backw comes from).
- (The real figure of course depends on the UTF-8 data.) */
+ /* The assumption is that the average size of a character is 2 bytes,
+ * so going forwards is twice the speed of going backwards (that's
+ * where the 2 * backw comes from). (The real figure of course depends
+ * on the UTF-8 data.) */
const U8 *s = start;
- while (s < send && uoffset--)
- s += UTF8SKIP(s);
+ s = utf8_hop_forward(s, uoffset, send);
assert (s <= send);
if (s > send)
s = send;
return s - start;
}
- while (backw--) {
- send--;
- while (UTF8_IS_CONTINUATION(*send))
- send--;
- }
+ send = utf8_hop_back(send, -backw, start);
return send - start;
}
}
while (end > target) {
- end--;
- while (UTF8_IS_CONTINUATION(*end)) {
- end--;
- }
+ end = utf8_hop_back(end, -1, target);
endu--;
}
return endu;
}
/*
-=for apidoc sv_eq
-
-Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and S<C<'use bytes'>> aware, handles get magic, and will
-coerce its args to strings if necessary.
+=for apidoc sv_eq
+=for apidoc_item sv_eq_flags
-This function does not handle operator overloading. For a version that does,
-see instead C<sv_streq>.
+These each return a boolean indicating whether or not the strings in the two
+SVs are equal. If S<C<'use bytes'>> is in effect, the comparison is
+byte-by-byte; otherwise character-by-character. Each will coerce its args to
+strings if necessary.
-=for apidoc sv_eq_flags
+They differ only in that C<sv_eq> always processes get magic, while
+C<sv_eq_flags> processes get magic only when the C<flags> parameter has the
+C<SV_GMAGIC> bit set.
-Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and S<C<'use bytes'>> aware and coerces its args to strings
-if necessary. If the flags has the C<SV_GMAGIC> bit set, it handles get-magic, too.
-
-This function does not handle operator overloading. For a version that does,
-see instead C<sv_streq_flags>.
+These functions do not handle operator overloading. For versions that do,
+see instead C<L</sv_streq>> or C<L</sv_streq_flags>>.
=cut
*/
* at the beginning of a character. But neither or both are
* (or else earlier bytes would have been different). And
* if we are in the middle of a character, the two
- * characters are comprised of the same number of bytes
+ * characters have the same number of bytes
* (because in this case the start bytes are the same, and
* the start bytes encode the character's length). */
if (UTF8_IS_INVARIANT(*pv1))
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);
SvPOK_only(sv);
if (!append) {
/* not appending - "clear" the string by setting SvCUR to 0,
- * the pv is still avaiable. */
+ * the pv is still available. */
SvCUR_set(sv,0);
}
if (PerlIO_isutf8(fp))
}
if (shortbuffered) { /* oh well, must extend */
- /* we didnt have enough room to fit the line into the target buffer
+ /* we didn't have enough room to fit the line into the target buffer
* so we must extend the target buffer and keep going */
cnt = shortbuffered;
shortbuffered = 0;
* sv_2mortal() and do what it does ourselves here. Since we have asserted
* that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
* can use it to enable the sv flags directly (bypassing SvTEMP_on), which
- * in turn means we dont need to mask out the SVf_UTF8 flag below, which
+ * in turn means we don't need to mask out the SVf_UTF8 flag below, which
* means that we eliminate quite a few steps than it looks - Yves
* (explaining patch by gfx) */
}
/*
+=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
SvUTF8_on (sv);
return sv;
}
- /* This will be overwhelminly the most common case. */
+ /* This will be overwhelmingly the most common case. */
{
/* Inline most of newSVpvn_share(), because share_hek_hek() is far
more efficient than sharepvn(). */
PERL_ARGS_ASSERT_VNEWSVPVF;
- new_SV(sv);
- sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+ sv = newSV(1);
+ SvPVCLEAR_FRESH(sv);
+ sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, 0);
return sv;
}
}
/*
-=for apidoc newRV_noinc
+=for apidoc newSVbool
-Creates an RV wrapper for an SV. The reference count for the original
-SV is B<not> incremented.
+Creates a new SV boolean.
=cut
*/
SV *
-Perl_newRV_noinc(pTHX_ SV *const tmpRef)
+Perl_newSVbool(pTHX_ bool bool_val)
{
- SV *sv;
+ PERL_ARGS_ASSERT_NEWSVBOOL;
+ SV *sv = newSVsv(bool_val ? &PL_sv_yes : &PL_sv_no);
- PERL_ARGS_ASSERT_NEWRV_NOINC;
+ return sv;
+}
- new_SV(sv);
+/*
+=for apidoc newSV_true
- /* 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);
+Creates a new SV that is a boolean true.
- SET_SVANY_FOR_BODYLESS_IV(sv);
- SvFLAGS(sv) |= SVt_IV;
+=cut
+*/
+SV *
+Perl_newSV_true(pTHX)
+{
+ PERL_ARGS_ASSERT_NEWSV_TRUE;
+ SV *sv = newSVsv(&PL_sv_yes);
- SvTEMP_off(tmpRef);
+ return sv;
+}
- sv_setrv_noinc(sv, tmpRef);
+/*
+=for apidoc newSV_false
+
+Creates a new SV that is a boolean false.
+
+=cut
+*/
+
+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 (!old)
return NULL;
- if (SvTYPE(old) == (svtype)SVTYPEMASK) {
+ if (SvIS_FREED(old)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return NULL;
}
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;
sv = GvSV(gv);
if (sv && !SvREADONLY(sv)) {
SV_CHECK_THINKFIRST_COW_DROP(sv);
- if (!isGV(sv)) SvOK_off(sv);
+ if (!isGV(sv)) {
+ SvOK_off(sv);
+ SvSETMAGIC(sv);
+ }
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
- if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
+ if (GvHV(gv) && !HvHasNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
}
}
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);
}
case SVt_PVIO: return "IO";
case SVt_INVLIST: return "INVLIST";
case SVt_REGEXP: return "REGEXP";
+ case SVt_PVOBJ: return "OBJECT";
default: return "UNKNOWN";
}
}
dst = sv_newmortal();
if (ob && SvOBJECT(sv)) {
- HvNAME_get(SvSTASH(sv))
- ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
- : sv_setpvs(dst, "__ANON__");
+ if (HvHasNAME(SvSTASH(sv)))
+ sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)));
+ else
+ sv_setpvs(dst, "__ANON__");
}
else {
const char * reftype = sv_reftype(sv, 0);
SvGETMAGIC(sv);
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
+ if (HvSTASH_IS_CLASS(stash))
+ Perl_croak(aTHX_ "Attempt to bless into a class");
+
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) {
if (SvREADONLY(tmpRef))
Perl_croak_no_modify();
+ if (SvTYPE(tmpRef) == SVt_PVOBJ)
+ Perl_croak(aTHX_ "Can't bless an object reference");
if (SvOBJECT(tmpRef)) {
oldstash = SvSTASH(tmpRef);
}
SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
if (GvGP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
- && HvNAME_get(stash))
+ && HvHasNAME(stash))
mro_method_changed_in(stash);
gp_free(MUTABLE_GV(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.
+ *
+ * %6p (HvNAMEf) Like %s, but using the HvNAME() and HvNAMELEN()
+ * %10p (HvNAMEf_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 == 6 || width == 10) {
+ HV *hv = va_arg(*args, HV *);
+ eptr = HvNAME(hv);
+ elen = HvNAMELEN(hv);
+ if (HvNAMEUTF8(hv))
+ is_utf8 = TRUE;
+ if (width == 10)
+ 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
#endif
-/* Certain cases in Perl_ss_dup have been merged, by relying on the fact
- that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
- If this changes, please unmerge ss_dup.
- Likewise, sv_dup_inc_multiple() relies on this fact. */
-#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
-#define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
-#define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
-#define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
-#define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
-#define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
-#define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
-#define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
-#define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
-#define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
-#define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
#define SAVEPV(p) ((p) ? savepv(p) : NULL)
#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
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_section $embedding
+=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)
return dest;
}
+/* duplicate the HvAUX of an HV */
+static void
+S_sv_dup_hvaux(pTHX_ const SV *const ssv, SV *dsv, CLONE_PARAMS *const param)
+{
+ PERL_ARGS_ASSERT_SV_DUP_HVAUX;
+
+ const struct xpvhv_aux * const saux = HvAUX(ssv);
+ struct xpvhv_aux * const daux = HvAUX(dsv);
+ /* This flag isn't copied. */
+ SvFLAGS(dsv) |= SVphv_HasAUX;
+
+ if (saux->xhv_name_count) {
+ HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
+ const I32 count = saux->xhv_name_count < 0
+ ? -saux->xhv_name_count
+ : saux->xhv_name_count;
+ HEK **shekp = sname + count;
+ HEK **dhekp;
+ Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
+ dhekp = daux->xhv_name_u.xhvnameu_names + count;
+ while (shekp-- > sname) {
+ dhekp--;
+ *dhekp = hek_dup(*shekp, param);
+ }
+ }
+ else {
+ daux->xhv_name_u.xhvnameu_name = hek_dup(saux->xhv_name_u.xhvnameu_name, param);
+ }
+ daux->xhv_name_count = saux->xhv_name_count;
+
+ daux->xhv_aux_flags = saux->xhv_aux_flags;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ daux->xhv_rand = saux->xhv_rand;
+ daux->xhv_last_rand = saux->xhv_last_rand;
+#endif
+ daux->xhv_riter = saux->xhv_riter;
+ daux->xhv_eiter = saux->xhv_eiter ? 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)
+ /* when joining, we let the individual GVs and
+ * CVs add themselves to backref as
+ * needed. This avoids pulling in stuff
+ * that isn't required, and simplifies the
+ * case where stashes aren't cloned back
+ * if they already exist in the parent
+ * thread */
+ ? NULL
+ : saux->xhv_backreferences
+ ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
+ ? MUTABLE_AV(SvREFCNT_inc(
+ sv_dup_inc((const SV *)
+ saux->xhv_backreferences, param)))
+ : MUTABLE_AV(sv_dup((const SV *)
+ saux->xhv_backreferences, param))
+ : 0;
+
+ daux->xhv_mro_meta = saux->xhv_mro_meta
+ ? mro_meta_dup(saux->xhv_mro_meta, param)
+ : 0;
+
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if (HvNAME(ssv))
+ av_push(param->stashes, dsv);
+
+ if (HvSTASH_IS_CLASS(ssv)) {
+ daux->xhv_class_superclass = hv_dup_inc(saux->xhv_class_superclass, param);
+ daux->xhv_class_initfields_cv = cv_dup_inc(saux->xhv_class_initfields_cv, param);
+ daux->xhv_class_adjust_blocks = av_dup_inc(saux->xhv_class_adjust_blocks, param);
+ daux->xhv_class_fields = padnamelist_dup_inc(saux->xhv_class_fields, param);
+ daux->xhv_class_next_fieldix = saux->xhv_class_next_fieldix;
+ daux->xhv_class_param_map = hv_dup_inc(saux->xhv_class_param_map, param);
+
+ /* TODO: This does mean that we can't compile more `field` expressions
+ * in the cloned thread, but surely we're done with compiletime now..?
+ */
+ daux->xhv_class_suspended_initfields_compcv = NULL;
+ }
+}
+
/* duplicate an SV of any type (including AV, HV etc) */
static SV *
PERL_ARGS_ASSERT_SV_DUP_COMMON;
- if (SvTYPE(ssv) == (svtype)SVTYPEMASK) {
+ if (SvIS_FREED(ssv)) {
#ifdef DEBUG_LEAKING_SCALARS_ABORT
abort();
#endif
switch (sv_type) {
default:
- Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(ssv));
+ Perl_croak(param->proto_perl, "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(ssv));
NOT_REACHED; /* NOTREACHED */
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);
goto have_body;
}
/* FALLTHROUGH */
+ case SVt_PVOBJ:
case SVt_PVGV:
case SVt_PVIO:
case SVt_PVFM:
sv_type_details->body_size + sv_type_details->offset, char);
#endif
- if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
+ if (sv_type != SVt_PVAV && sv_type != SVt_PVHV && sv_type != SVt_PVOBJ
&& !isGV_with_GP(dsv)
&& !isREGEXP(dsv)
&& !(sv_type == SVt_PVIO && !(IoFLAGS(dsv) & IOf_FAKE_DIRP)))
? he_dup(source, FALSE, param) : 0;
++i;
}
- if (SvOOK(ssv)) {
- const struct xpvhv_aux * const saux = HvAUX(ssv);
- struct xpvhv_aux * const daux = HvAUX(dsv);
- /* This flag isn't copied. */
- SvOOK_on(dsv);
-
- if (saux->xhv_name_count) {
- HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
- const I32 count
- = saux->xhv_name_count < 0
- ? -saux->xhv_name_count
- : saux->xhv_name_count;
- HEK **shekp = sname + count;
- HEK **dhekp;
- Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
- dhekp = daux->xhv_name_u.xhvnameu_names + count;
- while (shekp-- > sname) {
- dhekp--;
- *dhekp = hek_dup(*shekp, param);
- }
- }
- else {
- daux->xhv_name_u.xhvnameu_name
- = hek_dup(saux->xhv_name_u.xhvnameu_name,
- param);
- }
- daux->xhv_name_count = saux->xhv_name_count;
-
- daux->xhv_aux_flags = saux->xhv_aux_flags;
-#ifdef PERL_HASH_RANDOMIZE_KEYS
- daux->xhv_rand = saux->xhv_rand;
- daux->xhv_last_rand = saux->xhv_last_rand;
-#endif
- daux->xhv_riter = saux->xhv_riter;
- daux->xhv_eiter = saux->xhv_eiter
- ? 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)
- /* when joining, we let the individual GVs and
- * CVs add themselves to backref as
- * needed. This avoids pulling in stuff
- * that isn't required, and simplifies the
- * case where stashes aren't cloned back
- * if they already exist in the parent
- * thread */
- ? NULL
- : saux->xhv_backreferences
- ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
- ? MUTABLE_AV(SvREFCNT_inc(
- sv_dup_inc((const SV *)
- saux->xhv_backreferences, param)))
- : MUTABLE_AV(sv_dup((const SV *)
- saux->xhv_backreferences, param))
- : 0;
-
- daux->xhv_mro_meta = saux->xhv_mro_meta
- ? mro_meta_dup(saux->xhv_mro_meta, param)
- : 0;
-
- /* Record stashes for possible cloning in Perl_clone(). */
- if (HvNAME(ssv))
- av_push(param->stashes, dsv);
- }
+ if (HvHasAUX(ssv))
+ sv_dup_hvaux(ssv, dsv, param);
}
else
HvARRAY(MUTABLE_HV(dsv)) = NULL;
} 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));
padlist = padlist_dup(padlist, param);
CvPADLIST_set(dsv, padlist);
} else
-/* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */
+/* unthreaded perl can't sv_dup so we don't support unthreaded's CvHSCXT */
PoisonPADLIST(dsv);
CvOUTSIDE(dsv) =
? cv_dup( CvOUTSIDE(dsv), param)
: cv_dup_inc(CvOUTSIDE(dsv), param);
break;
+ case SVt_PVOBJ:
+ {
+ Size_t fieldcount = ObjectMAXFIELD(ssv) + 1;
+
+ Newx(ObjectFIELDS(dsv), fieldcount, SV *);
+ ObjectMAXFIELD(dsv) = fieldcount - 1;
+
+ sv_dup_inc_multiple(ObjectFIELDS(ssv), ObjectFIELDS(dsv), fieldcount, param);
+ }
+ break;
}
}
}
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)
nsi->si_prev = si_dup(si->si_prev, param);
nsi->si_next = si_dup(si->si_next, param);
nsi->si_markoff = si->si_markoff;
+#ifdef PERL_RC_STACK
+ nsi->si_stack_nonrc_base = si->si_stack_nonrc_base;
+#endif
#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
nsi->si_stack_hwm = 0;
#endif
#define pv_dup(p) SAVEPV(p)
#define svp_dup_inc(p,pp) any_dup(p,pp)
-/* map any object to the new equivent - either something in the
+/* map any object to the new equivalent - either something in the
* ptr table, or something in the interpreter structure
*/
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)
const GV *gv;
const AV *av;
const HV *hv;
+ char *pv; /* no const deliberately */
void* ptr;
int intval;
long longval;
SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix));
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
+ /* this feels very strange, we have a **SV from one thread,
+ * we copy the SV, but dont change the **SV. But in this thread
+ * the target of the **SV could be something from the *other* thread.
+ * So how can this possibly work correctly? */
+ break;
+ case SAVEt_RCPV:
+ pv = (char *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = rcpv_copy(pv);
+ ptr = POPPTR(ss,ix);
+ (void)rcpv_copy(*((char **)ptr));
+ TOPPTR(nss,ix) = ptr;
+ /* XXXXX: see comment above. */
break;
case SAVEt_GVSLOT: /* any slot in GV */
sv = (const SV *)POPPTR(ss,ix);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
break;
+ case SAVEt_FREERCPV:
+ c = (char *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = rcpv_copy(c);
+ break;
case SAVEt_STACK_POS: /* Position on Perl stack */
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
+ case SAVEt_CURCOP_WARNINGS:
+ /* FALLTHROUGH */
case SAVEt_COMPILE_WARNINGS:
ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
+ TOPPTR(nss,ix) = DUP_WARNINGS((char*)ptr);
break;
case SAVEt_PARSER:
ptr = POPPTR(ss,ix);
/* for each stash, determine whether its objects should be cloned */
S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
+ my_perl->Iphase = PERL_PHASE_CONSTRUCT;
PERL_SET_THX(my_perl);
#ifdef DEBUGGING
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_minus_c = proto_perl->Iminus_c;
PL_localpatches = proto_perl->Ilocalpatches;
- PL_splitstr = proto_perl->Isplitstr;
+ PL_splitstr = SAVEPV(proto_perl->Isplitstr);
PL_minus_n = proto_perl->Iminus_n;
PL_minus_p = proto_perl->Iminus_p;
PL_minus_l = proto_perl->Iminus_l;
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_subline = proto_perl->Isubline;
PL_cv_has_eval = proto_perl->Icv_has_eval;
-
-#ifdef USE_LOCALE_COLLATE
- PL_collation_ix = proto_perl->Icollation_ix;
- PL_collation_standard = proto_perl->Icollation_standard;
- PL_collxfrm_base = proto_perl->Icollxfrm_base;
- PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
- PL_strxfrm_max_cp = proto_perl->Istrxfrm_max_cp;
-#endif /* USE_LOCALE_COLLATE */
-
-#ifdef USE_LOCALE_NUMERIC
- PL_numeric_standard = proto_perl->Inumeric_standard;
- PL_numeric_underlying = proto_perl->Inumeric_underlying;
- PL_numeric_underlying_is_standard = proto_perl->Inumeric_underlying_is_standard;
-#endif /* !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;
-#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] */
Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
- /* This PV will be free'd special way so must set it same way op.c does */
- PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
- ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+ PL_compiling.cop_file = rcpv_copy(proto_perl->Icompiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
+ PL_hook__require__before = sv_dup_inc(proto_perl->Ihook__require__before, param);
+ PL_hook__require__after = sv_dup_inc(proto_perl->Ihook__require__after, param);
+
/* switches */
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_inplace = SAVEPV(proto_perl->Iinplace);
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("C");
}
#endif
+#ifdef USE_PL_CUR_LC_ALL
+ PL_cur_LC_ALL = SAVEPV("C");
+#endif
#ifdef USE_LOCALE_CTYPE
+ Copy(PL_fold, PL_fold_locale, 256, U8);
+
/* Should we warn if uses locale? */
+ PL_ctype_name = SAVEPV("C");
PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param);
+ PL_in_utf8_CTYPE_locale = false;
+ PL_in_utf8_turkic_locale = false;
#endif
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = false;
+
#ifdef USE_LOCALE_COLLATE
- PL_collation_name = SAVEPV(proto_perl->Icollation_name);
+ PL_in_utf8_COLLATE_locale = false;
+ PL_collation_name = SAVEPV("C");
+ PL_collation_ix = proto_perl->Icollation_ix;
+ PL_collation_standard = true;
+ PL_collxfrm_base = 0;
+ PL_collxfrm_mult = 0;
+ PL_strxfrm_max_cp = 0;
+ PL_strxfrm_is_behaved = proto_perl->Istrxfrm_is_behaved;
+ PL_strxfrm_NUL_replacement = '\0';
#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_THREADS
+ assert(PL_locale_mutex_depth <= 0);
+ PL_locale_mutex_depth = 0;
+#endif
+
#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_numeric_name = SAVEPV("C");
+ PL_numeric_radix_sv = newSVpvs(".");
+ PL_underlying_radix_sv = newSVpvs(".");
+ PL_numeric_standard = true;
+ PL_numeric_underlying = true;
+ PL_numeric_underlying_is_standard = true;
-# if defined(HAS_POSIX_2008_LOCALE)
- PL_underlying_numeric_obj = NULL;
-# endif
#endif /* !USE_LOCALE_NUMERIC */
+#if defined(USE_POSIX_2008_LOCALE)
+ PL_scratch_locale_obj = NULL;
+ PL_cur_locale_obj = PL_C_locale_obj;
+#endif
#ifdef HAS_MBRLEN
PL_mbrlen_ps = proto_perl->Imbrlen_ps;
PL_setlocale_buf = NULL;
PL_setlocale_bufsize = 0;
+#if defined(USE_LOCALE_THREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
+ PL_less_dicey_locale_buf = NULL;
+ PL_less_dicey_locale_bufsize = 0;
+#endif
+
/* 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);
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
- Newx(PL_markstack, i, I32);
+ Newx(PL_markstack, i, Stack_off_t);
PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
- proto_perl->Imarkstack);
PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
- proto_perl->Imarkstack);
Copy(proto_perl->Imarkstack, PL_markstack,
- PL_markstack_ptr - PL_markstack + 1, I32);
+ PL_markstack_ptr - PL_markstack + 1, Stack_off_t);
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
* NOTE: unlike the others! */
HV* const stash = MUTABLE_HV(av_shift(param->stashes));
GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
- dSP;
ENTER;
SAVETMPS;
- PUSHMARK(SP);
- mXPUSHs(newSVhek(HvNAME_HEK(stash)));
- PUTBACK;
+ PUSHMARK(PL_stack_sp);
+ rpp_extend(1);
+ SV *newsv = newSVhek(HvNAME_HEK(stash));
+ *++PL_stack_sp = newsv;
+ if (!rpp_stack_is_rc())
+ sv_2mortal(newsv);
call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
FREETMPS;
LEAVE;
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;
switch (obase->op_type) {
case OP_UNDEF:
- /* undef should care if its args are undef - any warnings
+ /* the optimizer rewrites '$x = undef' to 'undef $x' for lexical
+ * variables, which can occur as the source of warnings:
+ * ($x = undef) =~ s/a/b/;
+ * The OPpUNDEF_KEEP_PV flag indicates that this used to be an
+ * assignment op.
+ * Otherwise undef should not care if its args are undef - any warnings
* will be from tied/magic vars */
+ if (
+ (obase->op_private & (OPpTARGET_MY | OPpUNDEF_KEEP_PV)) == (OPpTARGET_MY | OPpUNDEF_KEEP_PV)
+ && (!match || PAD_SVl(obase->op_targ) == uninit_sv)
+ ) {
+ return varname(NULL, '$', obase->op_targ, NULL, 0, FUV_SUBSCRIPT_NONE);
+ }
break;
case OP_RV2AV:
return varname(NULL, '$', obase->op_targ,
NULL, 0, FUV_SUBSCRIPT_NONE);
+ case OP_PADSV_STORE:
+ if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+ goto do_op;
+ return varname(NULL, '$', obase->op_targ,
+ NULL, 0, FUV_SUBSCRIPT_NONE);
+
case OP_GVSV:
gv = cGVOPx_gv(obase);
if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
}
return varname(NULL, '$', obase->op_targ,
NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+
+ case OP_AELEMFASTLEX_STORE:
+ if (match) {
+ SV **svp;
+ AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
+ if (!av || SvRMAGICAL(av))
+ goto do_op;
+ svp = av_fetch(av, (I8)obase->op_private, FALSE);
+ if (!svp || *svp != uninit_sv)
+ goto do_op;
+ }
+ return varname(NULL, '$', obase->op_targ,
+ NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+
case OP_AELEMFAST:
{
gv = cGVOPx_gv(obase);
/*
+=for apidoc_section $warning
=for apidoc report_uninit
Print appropriate "Use of uninitialized variable" warning.
https://perl5.git.perl.org / perl5.git / blobdiff