#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.
/* 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))
{
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(
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.
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);
}
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);
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
*/
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)));
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)) {
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
+=for apidoc sv_eq
+=for apidoc_item sv_eq_flags
-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.
-
-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
-
-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.
+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.
-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))
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) */
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(). */
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;
}
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));
case SVt_PVIO: return "IO";
case SVt_INVLIST: return "INVLIST";
case SVt_REGEXP: return "REGEXP";
+ case SVt_PVOBJ: return "OBJECT";
default: return "UNKNOWN";
}
}
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);
}
* 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 > 9: reserved for future
* extensions. Warns, but then is treated as a
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),
#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)
};
/*
+=for apidoc_section $embedding
=for apidoc ptr_table_new
Create a new pointer-mapping table
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;
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 (HvHasAUX(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;
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;
}
}
}
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
*/
* the target of the **SV could be something from the *other* thread.
* So how can this possibly work correctly? */
break;
- case SAVEt_RCPV_FREE:
+ case SAVEt_RCPV:
pv = (char *)POPPTR(ss,ix);
TOPPTR(nss,ix) = rcpv_copy(pv);
ptr = 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;
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_numeric_underlying = true;
PL_numeric_underlying_is_standard = true;
-# 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;
PL_setlocale_buf = NULL;
PL_setlocale_bufsize = 0;
- PL_stdize_locale_buf = NULL;
- PL_stdize_locale_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 */
/* 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;
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);
https://perl5.git.perl.org / perl5.git / blobdiff