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. */
}
*/
void
-Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
+Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
{
dVAR;
void* old_body;
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
}
- if (old_type < SVt_PV) {
+ if (new_type == SVt_REGEXP)
+ sv->sv_u.svu_rx = (regexp *)new_body;
+ else if (old_type < SVt_PV) {
/* referant will be NULL unless the old type was SVt_IV emulating
SVt_RV */
sv->sv_u.svu_rv = referant;
*/
int
-Perl_sv_backoff(pTHX_ register SV *const sv)
+Perl_sv_backoff(pTHX_ SV *const sv)
{
STRLEN delta;
const char * const s = SvPVX_const(sv);
*/
char *
-Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
+Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
{
char *s;
*/
void
-Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
+Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
{
dVAR;
*/
void
-Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
+Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
{
PERL_ARGS_ASSERT_SV_SETIV_MG;
*/
void
-Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
+Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
{
PERL_ARGS_ASSERT_SV_SETUV;
*/
void
-Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
+Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
{
PERL_ARGS_ASSERT_SV_SETUV_MG;
*/
void
-Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
+Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
{
dVAR;
*/
void
-Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
+Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
{
PERL_ARGS_ASSERT_SV_SETNV_MG;
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
STATIC int
-S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
+S_sv_2iuv_non_preserve(pTHX_ SV *const sv
# ifdef DEBUGGING
, I32 numtype
# endif
*/
IV
-Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
return PTR2IV(SvRV(sv));
}
- if (SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
+ if (SvVALID(sv) || isREGEXP(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache IVs.
In practice they are extremely unlikely to actually get anywhere
Regexps have no SvIVX and SvNVX fields.
*/
- assert(SvPOKp(sv));
+ assert(isREGEXP(sv) || SvPOKp(sv));
{
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return I_V(Atof(SvPVX_const(sv)));
+ return I_V(Atof(ptr));
}
}
*/
UV
-Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
return PTR2UV(SvRV(sv));
}
- if (SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
+ if (SvVALID(sv) || isREGEXP(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache IVs.
Regexps have no SvIVX and SvNVX fields. */
- assert(SvPOKp(sv));
+ assert(isREGEXP(sv) || SvPOKp(sv));
{
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return U_V(Atof(SvPVX_const(sv)));
+ return U_V(Atof(ptr));
}
}
*/
NV
-Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
return 0.0;
- if (SvGMAGICAL(sv) || SvVALID(sv) || SvTYPE(sv) == SVt_REGEXP) {
+ if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache NVs.
Regexps have no SvIVX and SvNVX fields. */
+ const char *ptr;
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && !SvIOKp(sv)) {
+ ptr = SvPVX_const(sv);
+ grokpv:
if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
- !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
+ !grok_number(ptr, SvCUR(sv), NULL))
not_a_number(sv);
- return Atof(SvPVX_const(sv));
+ return Atof(ptr);
}
if (SvIOKp(sv)) {
if (SvIsUV(sv))
if (SvROK(sv)) {
goto return_rok;
}
+ if (isREGEXP(sv)) {
+ ptr = RX_WRAPPED((REGEXP *)sv);
+ goto grokpv;
+ }
assert(SvTYPE(sv) >= SVt_PVMG);
/* This falls through to the report_uninit near the end of the
function. */
*/
SV *
-Perl_sv_2num(pTHX_ register SV *const sv)
+Perl_sv_2num(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_2NUM;
*/
char *
-Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
+Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
char *s;
*lp = SvCUR(buffer);
return SvPVX(buffer);
}
+ else if (isREGEXP(sv)) {
+ if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
+ return RX_WRAPPED((REGEXP *)sv);
+ }
else {
if (lp)
*lp = 0;
*/
void
-Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
+Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
{
PERL_ARGS_ASSERT_SV_COPYPV;
}
void
-Perl_sv_copypv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
+Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
STRLEN len;
const char *s;
*/
char *
-Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp)
+Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
*/
char *
-Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
+Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVUTF8;
*/
bool
-Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
*/
STRLEN
-Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
+Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
{
dVAR;
*/
bool
-Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
+Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
{
dVAR;
*/
void
-Perl_sv_utf8_encode(pTHX_ register SV *const sv)
+Perl_sv_utf8_encode(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
*/
bool
-Perl_sv_utf8_decode(pTHX_ register SV *const sv)
+Perl_sv_utf8_decode(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UTF8_DECODE;
static void
S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
{
- SV * const sref = SvREFCNT_inc(SvRV(sstr));
+ SV * const sref = SvRV(sstr);
SV *dref = NULL;
const int intro = GvINTRO(dstr);
SV **location;
GvASSUMECV_on(dstr);
if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
}
- *location = sref;
+ *location = SvREFCNT_inc_simple_NN(sref);
if (import_flag && !(GvFLAGS(dstr) & import_flag)
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
void
-Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
+Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
{
dVAR;
U32 sflags;
break;
case SVt_REGEXP:
+ upgregexp:
if (dtype < SVt_REGEXP)
+ {
+ if (dtype >= SVt_PV) {
+ SvPV_free(dstr);
+ SvPV_set(dstr, 0);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
+ }
sv_upgrade(dstr, SVt_REGEXP);
+ }
break;
/* case SVt_BIND: */
return;
}
if (stype == SVt_PVLV)
+ {
+ if (isREGEXP(sstr)) goto upgregexp;
SvUPGRADE(dstr, SVt_PVNV);
+ }
else
SvUPGRADE(dstr, (svtype)stype);
}
}
}
}
- else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
+ else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
+ && (stype == SVt_REGEXP || isREGEXP(sstr))) {
reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
}
else if (sflags & SVp_POK) {
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. */
*/
void
-Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
+Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
{
PERL_ARGS_ASSERT_SV_SETSV_MG;
} 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);
*/
void
-Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
+Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
dVAR;
char *dptr;
*/
void
-Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
+Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
PERL_ARGS_ASSERT_SV_SETPVN_MG;
*/
void
-Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
dVAR;
STRLEN len;
*/
void
-Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
{
PERL_ARGS_ASSERT_SV_SETPV_MG;
}
void
-Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek)
+Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
{
dVAR;
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);
(which it can do by means other than releasing copy-on-write Svs)
or by changing the other copy-on-write SVs in the loop. */
STATIC void
-S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
+S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
{
PERL_ARGS_ASSERT_SV_RELEASE_COW;
/* 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;
*/
void
-Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
+Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
{
dVAR;
#ifdef PERL_OLD_COPY_ON_WRITE
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 = 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);
else if (SvFAKE(sv) && isGV_with_GP(sv))
sv_unglob(sv, flags);
- else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+ else if (SvFAKE(sv) && isREGEXP(sv)) {
/* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
to sv_unglob. We only need it here, so inline it. */
- const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+ const bool islv = SvTYPE(sv) == SVt_PVLV;
+ const svtype new_type =
+ islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
SV *const temp = newSV_type(new_type);
- void *const temp_p = SvANY(sv);
+ regexp *const temp_p = ReANY((REGEXP *)sv);
if (new_type == SVt_PVMG) {
SvMAGIC_set(temp, SvMAGIC(sv));
SvSTASH_set(temp, SvSTASH(sv));
SvSTASH_set(sv, NULL);
}
- SvCUR_set(temp, SvCUR(sv));
- /* Remember that SvPVX is in the head, not the body. */
- if (SvLEN(temp)) {
- SvLEN_set(temp, SvLEN(sv));
- /* This signals "buffer is owned by someone else" in sv_clear,
- which is the least effort way to stop it freeing the buffer.
- */
- SvLEN_set(sv, SvLEN(sv)+1);
- } else {
- /* Their buffer is already owned by someone else. */
- SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
- SvLEN_set(temp, SvCUR(sv)+1);
+ if (!islv) SvCUR_set(temp, SvCUR(sv));
+ /* Remember that SvPVX is in the head, not the body. But
+ RX_WRAPPED is in the body. */
+ assert(ReANY((REGEXP *)sv)->mother_re);
+ /* Their buffer is already owned by someone else. */
+ if (flags & SV_COW_DROP_PV) {
+ /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
+ zeroed body. For SVt_PVLV, it should have been set to 0
+ before turning into a regexp. */
+ assert(!SvLEN(islv ? sv : temp));
+ sv->sv_u.svu_pv = 0;
+ }
+ else {
+ sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
+ SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
+ SvPOK_on(sv);
}
/* Now swap the rest of the bodies. */
- SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
- SvFLAGS(sv) |= new_type;
- SvANY(sv) = SvANY(temp);
+ SvFAKE_off(sv);
+ if (!islv) {
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= new_type;
+ SvANY(sv) = SvANY(temp);
+ }
SvFLAGS(temp) &= ~(SVTYPEMASK);
SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
SvANY(temp) = temp_p;
+ temp->sv_u.svu_rx = (regexp *)temp_p;
SvREFCNT_dec(temp);
}
*/
void
-Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
{
STRLEN delta;
STRLEN old_delta;
*/
void
-Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
+Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
{
dVAR;
STRLEN dlen;
=cut */
void
-Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
+Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
dVAR;
=cut */
void
-Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
+Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
{
dVAR;
STRLEN len;
*/
void
-Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
{
PERL_ARGS_ASSERT_SV_CATPV_MG;
*/
void
-Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
+Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
const char *const name, const I32 namlen)
{
dVAR;
&& !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)) {
*/
void
-Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
+Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
{
dVAR;
const U32 refcnt = SvREFCNT(sv);
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
+ freeregexp:
pregfree2((REGEXP*) sv);
goto freescalar;
case SVt_PVCV:
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
+ if (isREGEXP(sv)) goto freeregexp;
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
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 (destructor
+ stash = SvSTASH(sv);
+ assert(SvTYPE(stash) == SVt_PVHV);
+ if (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) =
+ destructor ? (HV *)destructor : ((HV *)0)+1;
+ }
+ assert(!destructor || destructor == ((CV *)0)+1
+ || SvTYPE(destructor) == SVt_PVCV);
+ if (destructor && destructor != ((CV *)0)+1
/* A constant subroutine can have no side effects, so
don't bother calling it. */
&& !CvCONST(destructor)
}
SvREFCNT_dec(tmpref);
}
+ }
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
}
if (SvOBJECT(sv)) {
- SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+ HV * const stash = SvSTASH(sv);
+ /* Curse before freeing the stash, as freeing the stash could cause
+ a recursive call into S_curse. */
SvOBJECT_off(sv); /* Curse the object. */
+ SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
+ SvREFCNT_dec(stash); /* possibly of changed persuasion */
if (SvTYPE(sv) != SVt_PVIO)
--PL_sv_objcount;/* XXX Might want something more general */
}
*/
STRLEN
-Perl_sv_len(pTHX_ register SV *const sv)
+Perl_sv_len(pTHX_ SV *const sv)
{
STRLEN len;
*/
STRLEN
-Perl_sv_len_utf8(pTHX_ register SV *const sv)
+Perl_sv_len_utf8(pTHX_ SV *const sv)
{
if (!sv)
return 0;
/* This function is subject to size and sign problems */
void
-Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
+Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
{
PERL_ARGS_ASSERT_SV_POS_U2B;
*
*/
void
-Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
+Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
{
const U8* s;
const STRLEN byte = *offsetp;
*/
I32
-Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
+Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
{
dVAR;
const char *pv1;
*/
I32
-Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
+Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
{
return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
}
I32
-Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
dVAR;
*/
I32
-Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
+Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
{
return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
}
I32
-Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
dVAR;
*/
char *
-Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
+Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
dVAR;
const char *rsptr;
*/
void
-Perl_sv_inc(pTHX_ register SV *const sv)
+Perl_sv_inc(pTHX_ SV *const sv)
{
if (!sv)
return;
*/
void
-Perl_sv_inc_nomg(pTHX_ register SV *const sv)
+Perl_sv_inc_nomg(pTHX_ SV *const sv)
{
dVAR;
char *d;
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;
*/
void
-Perl_sv_dec(pTHX_ register SV *const sv)
+Perl_sv_dec(pTHX_ SV *const sv)
{
dVAR;
if (!sv)
*/
void
-Perl_sv_dec_nomg(pTHX_ register SV *const sv)
+Perl_sv_dec_nomg(pTHX_ SV *const sv)
{
dVAR;
int flags;
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 *
-Perl_sv_2mortal(pTHX_ register SV *const sv)
+Perl_sv_2mortal(pTHX_ SV *const sv)
{
dVAR;
if (!sv)
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);
*/
SV *
-Perl_newSVsv(pTHX_ register SV *const old)
+Perl_newSVsv(pTHX_ SV *const old)
{
dVAR;
SV *sv;
*/
void
-Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
+Perl_sv_reset(pTHX_ const char *s, HV *const stash)
{
PERL_ARGS_ASSERT_SV_RESET;
*/
I32
-Perl_sv_true(pTHX_ register SV *const sv)
+Perl_sv_true(pTHX_ SV *const sv)
{
if (!sv)
return 0;
*/
SV *
-Perl_sv_ref(pTHX_ register SV *dst, const SV *const sv, const int ob)
+Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
{
PERL_ARGS_ASSERT_SV_REF;
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;
{
PERL_ARGS_ASSERT_RVPV_DUP;
+ assert(!isREGEXP(sstr));
if (SvROK(sstr)) {
if (SvWEAKREF(sstr)) {
SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
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);
if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
&& !isGV_with_GP(dstr)
+ && !isREGEXP(dstr)
&& !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
- if (SvSTASH(dstr))
+ if (SvOBJECT(dstr) && 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. */
case SVt_PVMG:
break;
case SVt_REGEXP:
+ duprex:
/* FIXME for plugins */
+ dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
break;
case SVt_PVLV:
LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
+ if (isREGEXP(sstr)) goto duprex;
case SVt_PVGV:
/* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
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;
}