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.
}
}
}
-
- /* 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)),
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_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);
https://perl5.git.perl.org / perl5.git / blobdiff