dump all remaining SVs (debugging aid)
sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
- do_clean_named_io_objs()
+ do_clean_named_io_objs(),do_curse()
Attempt to free all objects pointed to by RVs,
- and try to do the same for all objects indirectly
- referenced by typeglobs too. Called once from
+ try to do the same for all objects indir-
+ ectly referenced by typeglobs too, and
+ then do a final sweep, cursing any
+ objects that remain. Called once from
perl_destruct(), prior to calling sv_clean_all()
below.
#endif
#ifdef DEBUG_LEAKING_SCALARS
-# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
+# define FREE_SV_DEBUG_FILE(sv) STMT_START { \
+ if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
+ } STMT_END
# define DEBUG_SV_SERIAL(sv) \
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
PTR2UV(sv), (long)(sv)->sv_debug_serial))
);
sv->sv_debug_inpad = 0;
sv->sv_debug_parent = NULL;
- sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+ sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
sv->sv_debug_serial = PL_sv_serial++;
}
}
}
-
- /* XXX Might want to check arrays, etc. */
}
shared hash keys then we don't do the COW setup, even if the
source scalar is a shared hash key scalar. */
(((flags & SV_COW_SHARED_HASH_KEYS)
- ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+ ? !(sflags & SVf_IsCOW)
: 1 /* If making a COW copy is forbidden then the behaviour we
desire is as if the source SV isn't actually already
COW, even if it is. So we act as if the source flags
}
#ifdef PERL_OLD_COPY_ON_WRITE
if (!isSwipe) {
- if ((sflags & (SVf_FAKE | SVf_READONLY))
- != (SVf_FAKE | SVf_READONLY)) {
- SvREADONLY_on(sstr);
- SvFAKE_on(sstr);
+ if (!(sflags & SVf_IsCOW)) {
+ SvIsCOW_on(sstr);
/* Make the source SV into a loop of 1.
(about to become 2) */
SV_COW_NEXT_SV_SET(sstr, sstr);
}
SvLEN_set(dstr, len);
SvCUR_set(dstr, cur);
- SvREADONLY_on(dstr);
- SvFAKE_on(dstr);
+ SvIsCOW_on(dstr);
}
else
{ /* Passes the swipe test. */
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
SvUPGRADE(sstr, SVt_PVIV);
- SvREADONLY_on(sstr);
- SvFAKE_on(sstr);
+ SvIsCOW_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Converting sstr to COW\n"));
SV_COW_NEXT_SV_SET(dstr, sstr);
common_exit:
SvPV_set(dstr, new_pv);
- SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+ SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_IsCOW);
if (SvUTF8(sstr))
SvUTF8_on(dstr);
SvLEN_set(dstr, len);
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on(sv);
return;
- } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
+ } else if (flags & HVhek_UNSHARED) {
sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
SvUTF8_on(sv);
SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
if (HEK_UTF8(hek))
SvUTF8_on(sv);
/* The SV we point to points back to us (there were only two of us
in the loop.)
Hence other SV is no longer copy on write either. */
- SvFAKE_off(after);
- SvREADONLY_off(after);
+ SvIsCOW_off(after);
} else {
/* We need to follow the pointers around the loop. */
SV *next;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
+ if (IN_PERL_RUNTIME)
+ Perl_croak_no_modify(aTHX);
+ }
+ else
if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvLEN(sv);
(long) flags);
sv_dump(sv);
}
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
+ SvIsCOW_off(sv);
/* This SV doesn't own the buffer, so need to Newx() a new one: */
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
sv_dump(sv);
}
}
- else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
- }
#else
if (SvREADONLY(sv)) {
+ if (IN_PERL_RUNTIME)
+ Perl_croak_no_modify();
+ }
+ else
if (SvIsCOW(sv)) {
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
+ SvIsCOW_off(sv);
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
}
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
- else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
- }
#endif
if (SvROK(sv))
sv_unref_flags(sv, flags);
&& !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
}
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
}
- SvFAKE_off(sv);
} else if (SvLEN(sv)) {
Safefree(SvPVX_mutable(sv));
}
Safefree(SvPVX_mutable(sv));
else if (SvPVX_const(sv) && SvIsCOW(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
- SvFAKE_off(sv);
}
#endif
break;
dSP;
HV* stash;
do {
- CV* destructor;
- stash = SvSTASH(sv);
- destructor = StashHANDLER(stash,DESTROY);
+ if ((stash = SvSTASH(sv)) && HvNAME(stash)) {
+ CV* destructor = NULL;
+ if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
+ if (!destructor) {
+ GV * const gv =
+ gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
+ if (gv && (destructor = GvCV(gv))) {
+ if (!SvOBJECT(stash))
+ SvSTASH(stash) = (HV *)destructor;
+ }
+ }
if (destructor
/* A constant subroutine can have no side effects, so
don't bother calling it. */
}
SvREFCNT_dec(tmpref);
}
+ }
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on (sv);
return sv;
- } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
- /* We don't have a pointer to the hv, so we have to replicate the
- flag into every HEK. This hv is using custom a hasing
- algorithm. Hence we can't return a shared string scalar, as
- that would contain the (wrong) hash value, and might get passed
- into an hv routine with a regular hash.
- Similarly, a hash that isn't using shared hash keys has to have
+ } else if (flags & HVhek_UNSHARED) {
+ /* A hash that isn't using shared hash keys has to have
the flag in every key so that we know not to try to call
share_hek_hek on it. */
SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
if (HEK_UTF8(hek))
SvUTF8_on(sv);
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
SvCUR_set(sv, len);
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
if (is_utf8)
SvUTF8_on(sv);
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
- if (SvREADONLY(sstr) && SvFAKE(sstr)) {
- /* Not that normal - actually sstr is copy on write.
- But we are a true, independent SV, so: */
- SvREADONLY_off(dstr);
- SvFAKE_off(dstr);
- }
+ /* sstr may not be that normal, but actually copy on write.
+ But we are a true, independent SV, so: */
+ SvIsCOW_off(dstr);
}
else {
/* Special case - not normally malloced for some reason */
if (isGV_with_GP(sstr)) {
/* Don't need to do anything here. */
}
- else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+ else if ((SvIsCOW(sstr))) {
/* A "shared" PV - clone it as "shared" PV */
SvPV_set(dstr,
HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
dstr->sv_debug_inpad = sstr->sv_debug_inpad;
dstr->sv_debug_parent = (SV*)sstr;
FREE_SV_DEBUG_FILE(dstr);
- dstr->sv_debug_file = savepv(sstr->sv_debug_file);
+ dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
#endif
ptr_table_store(PL_ptr_table, sstr, dstr);
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
+ else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
}
/* The cast silences a GCC warning about unhandled types. */
TOPUV(nss,ix) = uv;
switch (type) {
case SAVEt_CLEARSV:
+ case SAVEt_CLEARPADRANGE:
break;
case SAVEt_HELEM: /* hash element */
sv = (const SV *)POPPTR(ss,ix);
PL_Proc = ipP;
#endif /* PERL_IMPLICIT_SYS */
+
param->flags = flags;
/* Nothing in the core code uses this, but we make it available to
extensions (using mg_dup). */
param->new_perl = my_perl;
param->unreferenced = NULL;
+
INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
PL_body_arenas = NULL;
PL_debug = proto_perl->Idebug;
- PL_hash_seed = proto_perl->Ihash_seed;
- PL_rehash_seed = proto_perl->Irehash_seed;
-
/* dbargs array probably holds garbage */
PL_dbargs = NULL;
PL_origargc = proto_perl->Iorigargc;
PL_origargv = proto_perl->Iorigargv;
+#if !NO_TAINT_SUPPORT
/* Set tainting stuff before PerlIO_debug can possibly get called */
PL_tainting = proto_perl->Itainting;
PL_taint_warn = proto_perl->Itaint_warn;
+#else
+ PL_tainting = FALSE;
+ PL_taint_warn = FALSE;
+#endif
PL_minus_c = proto_perl->Iminus_c;
PL_timesbuf = proto_perl->Itimesbuf;
#endif
+#if !NO_TAINT_SUPPORT
PL_tainted = proto_perl->Itainted;
+#else
+ PL_tainted = FALSE;
+#endif
PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
+ PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
+ PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
#endif
+ /* reset stack AV to correct length before its duped via
+ * PL_curstackinfo */
+ AvFILLp(proto_perl->Icurstack) =
+ proto_perl->Istack_sp - proto_perl->Istack_base;
+
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
case OP_PADAV:
case OP_PADHV:
{
- const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
- const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ const bool pad = ( obase->op_type == OP_PADAV
+ || obase->op_type == OP_PADHV
+ || obase->op_type == OP_PADRANGE
+ );
+
+ const bool hash = ( obase->op_type == OP_PADHV
+ || obase->op_type == OP_RV2HV
+ || (obase->op_type == OP_PADRANGE
+ && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
+ );
I32 index = 0;
SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
case OP_OPEN:
o = cUNOPx(obase)->op_first;
- if (o->op_type == OP_PUSHMARK)
+ if ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
+ )
o = o->op_sibling;
if (!o->op_sibling) {
match = 1; /* print etc can return undef on defined args */
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
- if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+ if ((obase->op_flags & OPf_STACKED)
+ &&
+ ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
o = o->op_sibling->op_sibling;
goto do_op2;
* left that is not skipped, then we *know* it is responsible for
* the uninitialized value. If there is more than one op left, we
* have to look for an exact match in the while() loop below.
+ * Note that we skip padrange, because the individual pad ops that
+ * it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
+ || (type == OP_PADRANGE)
)
continue;
}
https://perl5.git.perl.org / perl5.git / blobdiff