{
#ifdef DEBUGGING
visit(do_report_used, 0, 0);
+#else
+ PERL_UNUSED_CONTEXT;
#endif
}
do_clean_named_objs(pTHX_ SV *sv)
{
dVAR;
- if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
+ if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) {
if ((
#ifdef PERL_DONT_CREATE_GVSV
GvSV(sv) &&
struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas;
for (; aroot; aroot = next) {
- int max = aroot->curr;
+ const int max = aroot->curr;
for (i=0; i<max; i++) {
assert(aroot->set[i].arena);
Safefree(aroot->set[i].arena);
*/
struct body_details {
- size_t body_size; /* Size to allocate */
- size_t copy; /* Size of structure to copy (may be shorter) */
- size_t offset;
- bool cant_upgrade; /* Cannot upgrade this type */
- bool zero_nv; /* zero the NV when upgrading from this */
- bool arena; /* Allocated from an arena */
- size_t arena_size; /* Size of arena to allocate */
+ U8 body_size; /* Size to allocate */
+ U8 copy; /* Size of structure to copy (may be shorter) */
+ U8 offset;
+ unsigned int type : 4; /* We have space for a sanity check. */
+ unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
+ unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
+ unsigned int arena : 1; /* Allocated from an arena */
+ size_t arena_size; /* Size of arena to allocate */
};
#define HADNV FALSE
limited by PERL_ARENA_SIZE, so we can safely oversize the
declarations.
*/
-#define FIT_ARENA(count, body_size) \
- (!count || count * body_size > PERL_ARENA_SIZE) \
- ? (int)(PERL_ARENA_SIZE / body_size) * body_size : count * body_size
+#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) \
+ count \
+ ? FIT_ARENAn (count, body_size) \
+ : FIT_ARENA0 (body_size)
/* A macro to work out the offset needed to subtract from a pointer to (say)
+ sizeof (((type*)SvANY((SV*)0))->last_member)
static const struct body_details bodies_by_type[] = {
- { sizeof(HE), 0, 0, FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
+ { sizeof(HE), 0, 0, SVt_NULL,
+ FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
/* IVs are in the head, so the allocation size is 0.
However, the slot is overloaded for PTEs. */
{ sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
sizeof(IV), /* This is used to copy out the IV body. */
- STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV,
+ STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
NOARENA /* IVS don't need an arena */,
/* But PTEs need to know the size of their arena */
FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
},
/* 8 bytes on most ILP32 with IEEE doubles */
- { sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA,
+ { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
FIT_ARENA(0, sizeof(NV)) },
/* RVs are in the head now. */
- { 0, 0, 0, FALSE, NONV, NOARENA, 0 },
+ { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
/* 8 bytes on most ILP32 with IEEE doubles */
{ sizeof(xpv_allocated),
copy_length(XPV, xpv_len)
- relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
+ relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
- FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
+ SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
/* 12 */
{ sizeof(xpviv_allocated),
copy_length(XPVIV, xiv_u)
- relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
+ relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
- FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
+ SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
/* 20 */
- { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV,
+ { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
/* 28 */
- { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV,
+ { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
/* 36 */
- { sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV,
+ { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
/* 48 */
- { sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV,
+ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
/* 64 */
- { sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV,
+ { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
{ sizeof(xpvav_allocated),
copy_length(XPVAV, xmg_stash)
- relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
+ relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
- TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
+ SVt_PVAV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
{ sizeof(xpvhv_allocated),
copy_length(XPVHV, xmg_stash)
- relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
+ relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
- TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
+ SVt_PVHV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
/* 56 */
{ sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
+ relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
- TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
+ SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
{ sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
+ relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
- TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
+ SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
/* XPVIO is 84 bytes, fits 48x */
- { sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV,
+ { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV,
HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
};
#define new_NOARENAZ(details) \
my_safecalloc((details)->body_size + (details)->offset)
+#ifdef DEBUGGING
+static bool done_sanity_check;
+#endif
+
STATIC void *
S_more_bodies (pTHX_ svtype sv_type)
{
dVAR;
void ** const root = &PL_body_roots[sv_type];
- const struct body_details *bdp = &bodies_by_type[sv_type];
+ const struct body_details * const bdp = &bodies_by_type[sv_type];
const size_t body_size = bdp->body_size;
char *start;
const char *end;
assert(bdp->arena_size);
+
+#ifdef DEBUGGING
+ if (!done_sanity_check) {
+ int i = SVt_LAST;
+
+ done_sanity_check = TRUE;
+
+ while (i--)
+ assert (bodies_by_type[i].type == i);
+ }
+#endif
+
start = (char*) Perl_get_arena(aTHX_ bdp->arena_size);
end = start + bdp->arena_size - body_size;
/* This flag bit is used to mean other things in other scalar types.
Given that it only has meaning inside the pad, it shouldn't be set
on anything that can get upgraded. */
- assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
+ assert(!SvPAD_TYPED(sv));
break;
default:
if (old_type_details->cant_upgrade)
SvPV_set(sv, NULL);
if (old_type >= SVt_PVMG) {
- SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
+ SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
}
break;
SvANY(sv) = new_body;
if (old_type_details->copy) {
- Copy((char *)old_body + old_type_details->offset,
- (char *)new_body + old_type_details->offset,
- old_type_details->copy, char);
+ /* There is now the potential for an upgrade from something without
+ an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
+ int offset = old_type_details->offset;
+ int length = old_type_details->copy;
+
+ if (new_type_details->offset > old_type_details->offset) {
+ int difference
+ = new_type_details->offset - old_type_details->offset;
+ offset += difference;
+ length -= difference;
+ }
+ assert (length >= 0);
+
+ Copy((char *)old_body + offset, (char *)new_body + offset, length,
+ char);
}
#ifndef NV_ZERO_IS_ALLBITS_ZERO
int
Perl_sv_backoff(pTHX_ register SV *sv)
{
+ PERL_UNUSED_CONTEXT;
assert(SvOOK(sv));
assert(SvTYPE(sv) != SVt_PVHV);
assert(SvTYPE(sv) != SVt_PVAV);
return grok_number(sbegin, len, NULL);
}
+STATIC char *
+S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number)
+{
+ const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
+ SV *const buffer = sv_newmortal();
+
+ /* FAKE globs can get coerced, so need to turn this off temporarily if it
+ is on. */
+ SvFAKE_off(gv);
+ gv_efullname3(buffer, gv, "*");
+ SvFLAGS(gv) |= wasfake;
+
+ if (want_number) {
+ /* We know that all GVs stringify to something that is not-a-number,
+ so no need to test that. */
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(buffer);
+ /* We just want something true to return, so that S_sv_2iuv_common
+ can tail call us and return true. */
+ return (char *) 1;
+ } else {
+ return SvPV(buffer, *len);
+ }
+}
+
/* Actually, ISO C leaves conversion of UV to IV undefined, but
until proven guilty, assume that things are not that bad... */
}
}
else {
+ if (isGV_with_GP(sv)) {
+ return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
+ }
+
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
#endif /* NV_PRESERVES_UV */
}
else {
+ if (isGV_with_GP(sv)) {
+ glob_2inpuv((GV *)sv, NULL, TRUE);
+ return 0.0;
+ }
+
if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
assert (SvTYPE(sv) >= SVt_NV);
#endif
}
else {
+ if (isGV_with_GP(sv)) {
+ return glob_2inpuv((GV *)sv, lp, FALSE);
+ }
+
if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
if (lp)
else {
if (SvNOKp(sv))
return SvNVX(sv) != 0.0;
- else
- return FALSE;
+ else {
+ if (isGV_with_GP(sv))
+ return TRUE;
+ else
+ return FALSE;
+ }
}
}
}
const char * const name = GvNAME(sstr);
const STRLEN len = GvNAMELEN(sstr);
/* don't upgrade SVt_PVLV: it can hold a glob */
- if (dtype != SVt_PVLV)
+ if (dtype != SVt_PVLV) {
+ if (dtype >= SVt_PV) {
+ SvPV_free(dstr);
+ SvPV_set(dstr, 0);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
+ }
sv_upgrade(dstr, SVt_PVGV);
- sv_magic(dstr, dstr, PERL_MAGIC_glob, NULL, 0);
+ (void)SvOK_off(dstr);
+ SvSCREAM_on(dstr);
+ }
GvSTASH(dstr) = GvSTASH(sstr);
if (GvSTASH(dstr))
Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
}
#endif
+ gp_free((GV*)dstr);
+ SvSCREAM_off(dstr);
(void)SvOK_off(dstr);
+ SvSCREAM_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
- gp_free((GV*)dstr);
GvGP(dstr) = gp_ref(GvGP(sstr));
if (SvTAINTED(sstr))
SvTAINT(dstr);
}
break;
}
- if (dref)
- SvREFCNT_dec(dref);
+ SvREFCNT_dec(dref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
return;
sv_upgrade(dstr, SVt_IV);
break;
case SVt_NV:
- sv_upgrade(dstr, SVt_PVNV);
- break;
case SVt_RV:
case SVt_PV:
sv_upgrade(dstr, SVt_PVIV);
if (dtype < SVt_PVNV)
sv_upgrade(dstr, SVt_PVNV);
break;
- case SVt_PVAV:
- case SVt_PVHV:
- case SVt_PVCV:
- case SVt_PVIO:
+ default:
{
const char * const type = sv_reftype(sstr,0);
if (PL_op)
}
/*FALLTHROUGH*/
- default:
+ case SVt_PVMG:
+ case SVt_PVLV:
+ case SVt_PVBM:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if ((int)SvTYPE(sstr) != stype) {
SvUPGRADE(dstr, (U32)stype);
}
+ /* dstr may have been upgraded. */
+ dtype = SvTYPE(dstr);
sflags = SvFLAGS(sstr);
if (sflags & SVf_ROK) {
assert(!(sflags & SVf_NOK));
assert(!(sflags & SVf_IOK));
}
+ else if (dtype == SVt_PVGV) {
+ if (!(sflags & SVf_OK)) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Undefined value assigned to typeglob");
+ }
+ else {
+ GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
+ if (dstr != (SV*)gv) {
+ if (GvGP(dstr))
+ gp_free((GV*)dstr);
+ GvGP(dstr) = gp_ref(GvGP(gv));
+ }
+ }
+ }
else if (sflags & SVp_POK) {
bool isSwipe = 0;
}
}
else {
- if (dtype == SVt_PVGV) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
+ if (isGV_with_GP(sstr)) {
+ /* This stringification rule for globs is spread in 3 places.
+ This feels bad. FIXME. */
+ const U32 wasfake = sflags & SVf_FAKE;
+
+ /* FAKE globs can get coerced, so need to turn this off
+ temporarily if it is on. */
+ SvFAKE_off(sstr);
+ gv_efullname3(dstr, (GV *)sstr, "*");
+ SvFLAGS(sstr) |= wasfake;
}
else
(void)SvOK_off(dstr);
mg->mg_obj = obj;
}
else {
- mg->mg_obj = SvREFCNT_inc(obj);
+ mg->mg_obj = SvREFCNT_inc_simple(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
if (namlen > 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
- mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
else
mg->mg_ptr = (char *) name;
}
case PERL_MAGIC_defelem:
vtable = &PL_vtbl_defelem;
break;
- case PERL_MAGIC_glob:
- vtable = &PL_vtbl_glob;
- break;
case PERL_MAGIC_arylen:
vtable = &PL_vtbl_arylen;
break;
MAGIC** mgp;
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
return 0;
- mgp = &SvMAGIC(sv);
+ mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
for (mg = *mgp; mg; mg = *mgp) {
if (mg->mg_type == type) {
const MGVTBL* const vtbl = mg->mg_virtual;
} else {
av = newAV();
AvREAL_off(av);
- SvREFCNT_inc(av);
+ SvREFCNT_inc_simple_void(av);
}
*avp = av;
}
}
}
if (type >= SVt_PVMG) {
- if (SvMAGIC(sv))
+ HV *ourstash;
+ if ((type == SVt_PVMG || type == SVt_PVGV) &&
+ (ourstash = OURSTASH(sv))) {
+ SvREFCNT_dec(ourstash);
+ } else if (SvMAGIC(sv))
mg_free(sv);
- if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
+ if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
case SVt_PV:
case SVt_RV:
if (SvROK(sv)) {
- SV *target = SvRV(sv);
+ SV * const target = SvRV(sv);
if (SvWEAKREF(sv))
sv_del_backref(target, sv);
else
SV *
Perl_sv_newref(pTHX_ SV *sv)
{
+ PERL_UNUSED_CONTEXT;
if (sv)
(SvREFCNT(sv))++;
return sv;
if (cur1 == cur2)
eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
- if (svrecode)
- SvREFCNT_dec(svrecode);
-
+ SvREFCNT_dec(svrecode);
if (tpv)
Safefree(tpv);
}
}
- if (svrecode)
- SvREFCNT_dec(svrecode);
-
+ SvREFCNT_dec(svrecode);
if (tpv)
Safefree(tpv);
Perl_newRV(pTHX_ SV *tmpRef)
{
dVAR;
- return newRV_noinc(SvREFCNT_inc(tmpRef));
+ return newRV_noinc(SvREFCNT_inc_simple(tmpRef));
}
/*
if (SvTYPE(tmpRef) != SVt_PVIO)
++PL_sv_objcount;
SvUPGRADE(tmpRef, SVt_PVMG);
- SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
+ SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
{
dVAR;
void *xpvmg;
+ SV * const temp = sv_newmortal();
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
- if (GvGP(sv))
+ gv_efullname3(temp, (GV *) sv, "*");
+
+ if (GvGP(sv)) {
gp_free((GV*)sv);
+ }
if (GvSTASH(sv)) {
sv_del_backref((SV*)GvSTASH(sv), sv);
GvSTASH(sv) = NULL;
}
- sv_unmagic(sv, PERL_MAGIC_glob);
- Safefree(GvNAME(sv));
GvMULTI_off(sv);
+ Safefree(GvNAME(sv));
+ SvSCREAM_off(sv);
/* need to keep SvANY(sv) in the right arena */
xpvmg = new_XPVMG();
SvFLAGS(sv) &= ~SVTYPEMASK;
SvFLAGS(sv) |= SVt_PVMG;
+
+ /* Intentionally not calling any local SET magic, as this isn't so much a
+ set operation as merely an internal storage change. */
+ sv_setsv_flags(sv, temp, 0);
}
/*
DIR *
Perl_dirp_dup(pTHX_ DIR *dp)
{
+ PERL_UNUSED_CONTEXT;
if (!dp)
return (DIR*)NULL;
/* XXX TODO */
Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
{
GP *ret;
+
if (!gp)
return (GP*)NULL;
/* look for it in the table first */
Perl_ptr_table_new(pTHX)
{
PTR_TBL_t *tbl;
+ PERL_UNUSED_CONTEXT;
+
Newxz(tbl, 1, PTR_TBL_t);
tbl->tbl_max = 511;
tbl->tbl_items = 0;
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
{
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
+ PERL_UNUSED_CONTEXT;
return tblent ? tblent->newval : (void *) 0;
}
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
{
- PTR_TBL_ENT_t *tblent = S_ptr_table_find(tbl, oldsv);
+ PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
+ PERL_UNUSED_CONTEXT;
if (tblent) {
tblent->newval = newsv;
const UV oldsize = tbl->tbl_max + 1;
UV newsize = oldsize * 2;
UV i;
+ PERL_UNUSED_CONTEXT;
Renew(ary, newsize, PTR_TBL_ENT_t*);
Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
}
else {
/* Special case - not normally malloced for some reason */
- if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+ if (isGV_with_GP(sstr)) {
+ /* Don't need to do anything here. */
+ }
+ else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
/* A "shared" PV - clone it as "shared" PV */
SvPV_set(dstr,
HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
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
+ && !isGV_with_GP(dstr))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
/* The Copy above means that all the source (unduplicated) pointers
missing by always going for the destination.
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
- if (SvMAGIC(dstr))
+ HV *ourstash;
+ if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) {
+ OURSTASH_set(dstr, hv_dup_inc(ourstash, param));
+ } else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
break;
case SVt_PVGV:
GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
- GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
/* Don't call sv_add_backref here as it's going to be created
as part of the magic cloning of the symbol table. */
- GvGP(dstr) = gp_dup(GvGP(dstr), param);
- (void)GpREFCNT_inc(GvGP(dstr));
+ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
+ if(isGV_with_GP(sstr)) {
+ /* Danger Will Robinson - GvGP(dstr) isn't initialised
+ at the point of this comment. */
+ GvGP(dstr) = gp_dup(GvGP(sstr), param);
+ (void)GpREFCNT_inc(GvGP(dstr));
+ } else
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVIO:
IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
proto_perl->Ttmps_stack[i]);
if (nsv && !SvREFCNT(nsv)) {
EXTEND_MORTAL(1);
- PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc(nsv);
+ PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
}
}
}
/* orphaned? eg threads->new inside BEGIN or use */
if (PL_compcv && ! SvREFCNT(PL_compcv)) {
- (void)SvREFCNT_inc(PL_compcv);
+ SvREFCNT_inc_simple_void(PL_compcv);
SAVEFREESV(PL_compcv);
}
https://perl5.git.perl.org / perl5.git / blobdiff