/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#ifdef PERL_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
-#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
+#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
on-write. */
#endif
* "A time to plant, and a time to uproot what was planted..."
*/
+#ifdef DEBUG_LEAKING_SCALARS
+# ifdef NETWARE
+# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
+# else
+# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
+# endif
+#else
+# define FREE_SV_DEBUG_FILE(sv)
+#endif
+
#define plant_SV(p) \
STMT_START { \
+ FREE_SV_DEBUG_FILE(p); \
SvANY(p) = (void *)PL_sv_root; \
SvFLAGS(p) = SVTYPEMASK; \
PL_sv_root = (p); \
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
+ sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
+ sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
+ (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
+ sv->sv_debug_inpad = 0;
+ sv->sv_debug_cloned = 0;
+# ifdef NETWARE
+ sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+# else
+ sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
+# endif
+
return sv;
}
# define new_SV(p) (p)=S_new_SV(aTHX)
if (SvWEAKREF(sv)) {
sv_del_backref(sv);
SvWEAKREF_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
} else {
SvROK_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
SvREFCNT_dec(rv);
}
}
#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
STATIC SV*
-S_varname(pTHX_ GV *gv, char *gvtype, PADOFFSET targ,
+S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
SV* keyname, I32 aindex, int subscript_type)
{
AV *av;
* XXX get rid of all this if gv_fullnameX() ever supports this
* directly */
- char *p;
+ const char *p;
HV *hv = GvSTASH(gv);
sv_setpv(name, gvtype);
if (!hv)
p = "???";
- else if (!HvNAME(hv))
+ else if (!(p=HvNAME(hv)))
p = "__ANON__";
- else
- p = HvNAME(hv);
if (strNE(p, "main")) {
sv_catpv(name,p);
sv_catpvn(name,"::", 2);
Perl_croak(aTHX_ "Can't upgrade to undef");
case SVt_IV:
SvANY(sv) = new_XIV();
- SvIVX(sv) = iv;
+ SvIV_set(sv, iv);
break;
case SVt_NV:
SvANY(sv) = new_XNV();
- SvNVX(sv) = nv;
+ SvNV_set(sv, nv);
break;
case SVt_RV:
SvANY(sv) = new_XRV();
- SvRV(sv) = (SV*)pv;
+ SvRV_set(sv, (SV*)pv);
break;
case SVt_PV:
SvANY(sv) = new_XPV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
break;
case SVt_PVIV:
SvANY(sv) = new_XPVIV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
if (SvNIOK(sv))
(void)SvIOK_on(sv);
SvNOK_off(sv);
break;
case SVt_PVNV:
SvANY(sv) = new_XPVNV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
break;
case SVt_PVMG:
SvANY(sv) = new_XPVMG();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
break;
case SVt_PVLV:
SvANY(sv) = new_XPVLV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
LvTARGOFF(sv) = 0;
LvTARGLEN(sv) = 0;
LvTARG(sv) = 0;
SvANY(sv) = new_XPVAV();
if (pv)
Safefree(pv);
- SvPVX(sv) = 0;
+ SvPV_set(sv, (char*)0);
AvMAX(sv) = -1;
AvFILLp(sv) = -1;
- SvIVX(sv) = 0;
- SvNVX(sv) = 0.0;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvIV_set(sv, 0);
+ SvNV_set(sv, 0.0);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
AvALLOC(sv) = 0;
AvARYLEN(sv) = 0;
AvFLAGS(sv) = AVf_REAL;
SvANY(sv) = new_XPVHV();
if (pv)
Safefree(pv);
- SvPVX(sv) = 0;
+ SvPV_set(sv, (char*)0);
HvFILL(sv) = 0;
HvMAX(sv) = 0;
HvTOTALKEYS(sv) = 0;
HvPLACEHOLDERS(sv) = 0;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
HvRITER(sv) = 0;
HvEITER(sv) = 0;
HvPMROOT(sv) = 0;
case SVt_PVCV:
SvANY(sv) = new_XPVCV();
Zero(SvANY(sv), 1, XPVCV);
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
break;
case SVt_PVGV:
SvANY(sv) = new_XPVGV();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
GvGP(sv) = 0;
GvNAME(sv) = 0;
GvNAMELEN(sv) = 0;
break;
case SVt_PVBM:
SvANY(sv) = new_XPVBM();
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
BmRARE(sv) = 0;
BmUSEFUL(sv) = 0;
BmPREVIOUS(sv) = 0;
case SVt_PVFM:
SvANY(sv) = new_XPVFM();
Zero(SvANY(sv), 1, XPVFM);
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
break;
case SVt_PVIO:
SvANY(sv) = new_XPVIO();
Zero(SvANY(sv), 1, XPVIO);
- SvPVX(sv) = pv;
- SvCUR(sv) = cur;
- SvLEN(sv) = len;
- SvIVX(sv) = iv;
- SvNVX(sv) = nv;
- SvMAGIC(sv) = magic;
- SvSTASH(sv) = stash;
+ SvPV_set(sv, pv);
+ SvCUR_set(sv, cur);
+ SvLEN_set(sv, len);
+ SvIV_set(sv, iv);
+ SvNV_set(sv, nv);
+ SvMAGIC_set(sv, magic);
+ SvSTASH_set(sv, stash);
IoPAGE_LEN(sv) = 60;
break;
}
assert(SvOOK(sv));
if (SvIVX(sv)) {
char *s = SvPVX(sv);
- SvLEN(sv) += SvIVX(sv);
- SvPVX(sv) -= SvIVX(sv);
+ SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
+ SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
SvIV_set(sv, 0);
Move(s, SvPVX(sv), SvCUR(sv)+1, char);
}
#endif
Renew(s,newlen,char);
}
- else {
+ else {
New(703, s, newlen, char);
if (SvPVX(sv) && SvCUR(sv)) {
Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
OP_DESC(PL_op));
}
(void)SvIOK_only(sv); /* validate number */
- SvIVX(sv) = i;
+ SvIV_set(sv, i);
SvTAINT(sv);
}
}
sv_setiv(sv, 0);
SvIsUV_on(sv);
- SvUVX(sv) = u;
+ SvUV_set(sv, u);
}
/*
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
}
- SvNVX(sv) = num;
+ SvNV_set(sv, num);
(void)SvNOK_only(sv); /* validate number */
SvTAINT(sv);
}
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
- SvIVX(sv) = IV_MIN;
+ SvIV_set(sv, IV_MIN);
return IS_NUMBER_UNDERFLOW_IV;
}
if (SvNVX(sv) > (NV)UV_MAX) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
SvIsUV_on(sv);
- SvUVX(sv) = UV_MAX;
+ SvUV_set(sv, UV_MAX);
return IS_NUMBER_OVERFLOW_UV;
}
(void)SvIOKp_on(sv);
/* Can't use strtol etc to convert this string. (See truth table in
sv_2iv */
if (SvNVX(sv) <= (UV)IV_MAX) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv); /* Integer is precise. NOK, IOK */
} else {
return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
}
SvIsUV_on(sv);
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
if (SvUVX(sv) == UV_MAX) {
/* As we know that NVs don't preserve UVs, UV_MAX cannot
answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
cases go to UV */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
#ifndef NV_PRESERVES_UV
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
0x8000000000000000 which will be exact. NWC */
}
else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if (
(SvNVX(sv) == (NV) SvUVX(sv))
#ifndef NV_PRESERVES_UV
if (!(numtype & IS_NUMBER_NEG)) {
/* positive */;
if (value <= (UV)IV_MAX) {
- SvIVX(sv) = (IV)value;
+ SvIV_set(sv, (IV)value);
} else {
- SvUVX(sv) = value;
+ SvUV_set(sv, value);
SvIsUV_on(sv);
}
} else {
/* 2s complement assumption */
if (value <= (UV)IV_MIN) {
- SvIVX(sv) = -(IV)value;
+ SvIV_set(sv, -(IV)value);
} else {
/* Too negative for an IV. This is a double upgrade, but
I'm assuming it will be rare. */
SvNOK_on(sv);
SvIOK_off(sv);
SvIOKp_on(sv);
- SvNVX(sv) = -(NV)value;
- SvIVX(sv) = IV_MIN;
+ SvNV_set(sv, -(NV)value);
+ SvIV_set(sv, IV_MIN);
}
}
}
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
!= IS_NUMBER_IN_UV) {
/* It wasn't an (integer that doesn't overflow the UV). */
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
} else {
if (SvNVX(sv) > (NV)UV_MAX) {
SvIsUV_on(sv);
/* Integer is inaccurate. NOK, IOKp, is UV */
- SvUVX(sv) = UV_MAX;
+ SvUV_set(sv, UV_MAX);
SvIsUV_on(sv);
} else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
/* 0xFFFFFFFFFFFFFFFF not an issue in here */
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
/* Small enough to preserve all bits. */
(void)SvIOKp_on(sv);
SvNOK_on(sv);
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv))
SvIOK_on(sv);
/* Assumption: first non-preserved integer is < IV_MAX,
(void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
#ifndef NV_PRESERVES_UV
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
0x8000000000000000 which will be exact. NWC */
}
else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
if (
(SvNVX(sv) == (NV) SvUVX(sv))
#ifndef NV_PRESERVES_UV
if (!(numtype & IS_NUMBER_NEG)) {
/* positive */;
if (value <= (UV)IV_MAX) {
- SvIVX(sv) = (IV)value;
+ SvIV_set(sv, (IV)value);
} else {
/* it didn't overflow, and it was positive. */
- SvUVX(sv) = value;
+ SvUV_set(sv, value);
SvIsUV_on(sv);
}
} else {
/* 2s complement assumption */
if (value <= (UV)IV_MIN) {
- SvIVX(sv) = -(IV)value;
+ SvIV_set(sv, -(IV)value);
} else {
/* Too negative for an IV. This is a double upgrade, but
I'm assuming it will be rare. */
SvNOK_on(sv);
SvIOK_off(sv);
SvIOKp_on(sv);
- SvNVX(sv) = -(NV)value;
- SvIVX(sv) = IV_MIN;
+ SvNV_set(sv, -(NV)value);
+ SvIV_set(sv, IV_MIN);
}
}
}
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
!= IS_NUMBER_IN_UV) {
/* It wasn't an integer, or it overflowed the UV. */
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
} else {
if (SvNVX(sv) > (NV)UV_MAX) {
SvIsUV_on(sv);
/* Integer is inaccurate. NOK, IOKp, is UV */
- SvUVX(sv) = UV_MAX;
+ SvUV_set(sv, UV_MAX);
SvIsUV_on(sv);
} else {
- SvUVX(sv) = U_V(SvNVX(sv));
+ SvUV_set(sv, U_V(SvNVX(sv)));
/* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
NV preservse UV so can do correct comparison. */
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
/* Small enough to preserve all bits. */
(void)SvIOKp_on(sv);
SvNOK_on(sv);
- SvIVX(sv) = I_V(SvNVX(sv));
+ SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv))
SvIOK_on(sv);
/* Assumption: first non-preserved integer is < IV_MAX,
return SvNVX(sv);
}
if (SvIOKp(sv)) {
- SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
+ SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
#ifdef NV_PRESERVES_UV
SvNOK_on(sv);
#else
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
/* It's definitely an integer */
- SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
+ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
} else
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
SvNOK_on(sv);
#else
- SvNVX(sv) = Atof(SvPVX(sv));
+ SvNV_set(sv, Atof(SvPVX(sv)));
/* Only set the public NV OK flag if this NV preserves the value in
the PV at least as well as an IV/UV would.
Not sure how to do this 100% reliably. */
SvIOKp_on(sv);
if (numtype & IS_NUMBER_NEG) {
- SvIVX(sv) = -(IV)value;
+ SvIV_set(sv, -(IV)value);
} else if (value <= (UV)IV_MAX) {
- SvIVX(sv) = (IV)value;
+ SvIV_set(sv, (IV)value);
} else {
- SvUVX(sv) = value;
+ SvUV_set(sv, value);
SvIsUV_on(sv);
}
if (!sv) {
*lp = 0;
- return "";
+ return (char *)"";
}
if (SvGMAGICAL(sv)) {
if (flags & SV_GMAGIC)
report_uninit(sv);
}
*lp = 0;
- return "";
+ return (char *)"";
}
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
SV* tmpstr;
+ register const char *typestr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
(!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
char *pv = SvPV(tmpstr, *lp);
origsv = sv;
sv = (SV*)SvRV(sv);
if (!sv)
- s = "NULLREF";
+ typestr = "NULLREF";
else {
MAGIC *mg;
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_SMG))
&& (mg = mg_find(sv, PERL_MAGIC_qr))) {
- regexp *re = (regexp *)mg->mg_obj;
+ const regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
- char *fptr = "msix";
+ const char *fptr = "msix";
char reflags[6];
char ch;
int left = 0;
*/
if (PMf_EXTENDED & re->reganch)
{
- char *endptr = re->precomp + re->prelen;
+ const char *endptr = re->precomp + re->prelen;
while (endptr >= re->precomp)
{
- char c = *(endptr--);
+ const char c = *(endptr--);
if (c == '\n')
break; /* don't need another */
if (c == '#') {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
- case SVt_PVBM: if (SvROK(sv))
- s = "REF";
- else
- s = "SCALAR"; break;
- case SVt_PVLV: s = SvROK(sv) ? "REF"
+ case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
+ case SVt_PVLV: typestr = SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatitbility */
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
? "SCALAR" : "LVALUE"; break;
- case SVt_PVAV: s = "ARRAY"; break;
- case SVt_PVHV: s = "HASH"; break;
- case SVt_PVCV: s = "CODE"; break;
- case SVt_PVGV: s = "GLOB"; break;
- case SVt_PVFM: s = "FORMAT"; break;
- case SVt_PVIO: s = "IO"; break;
- default: s = "UNKNOWN"; break;
+ case SVt_PVAV: typestr = "ARRAY"; break;
+ case SVt_PVHV: typestr = "HASH"; break;
+ case SVt_PVCV: typestr = "CODE"; break;
+ case SVt_PVGV: typestr = "GLOB"; break;
+ case SVt_PVFM: typestr = "FORMAT"; break;
+ case SVt_PVIO: typestr = "IO"; break;
+ default: typestr = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
- if (SvOBJECT(sv))
- if (HvNAME(SvSTASH(sv)))
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
- else
- Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
+ if (SvOBJECT(sv)) {
+ const char *name = HvNAME(SvSTASH(sv));
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
+ name ? name : "__ANON__" , typestr, PTR2UV(sv));
+ }
else
- sv_setpv(tsv, s);
- Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
+ Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
goto tokensaveref;
}
- *lp = strlen(s);
- return s;
+ *lp = strlen(typestr);
+ return (char *)typestr;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
*lp = 0;
- return "";
+ return (char *)"";
}
}
if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
- U32 isIOK = SvIOK(sv);
- U32 isUIOK = SvIsUV(sv);
+ const U32 isIOK = SvIOK(sv);
+ const U32 isUIOK = SvIsUV(sv);
char buf[TYPE_CHARS(UV)];
char *ebuf, *ptr;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_PV);
- return "";
+ return (char *)"";
}
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
}
else {
STRLEN len;
- char *t;
+ const char *t;
if (tsv) {
sv_2mortal(tsv);
(void)SvOOK_off(sv);
s = (U8*)SvPVX(sv);
len = SvCUR(sv) + 1; /* Plus the \0 */
- SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
- SvCUR(sv) = len - 1;
+ SvPV_set(sv, (char*)bytes_to_utf8((U8*)s, &len));
+ SvCUR_set(sv, len - 1);
if (SvLEN(sv) != 0)
Safefree(s); /* No longer using what was there before. */
- SvLEN(sv) = len; /* No longer know the real size. */
+ SvLEN_set(sv, len); /* No longer know the real size. */
}
/* Mark as UTF-8 even if no hibit - saves scanning loop */
SvUTF8_on(sv);
Perl_croak(aTHX_ "Wide character");
}
}
- SvCUR(sv) = len;
+ SvCUR_set(sv, len);
}
}
SvUTF8_off(sv);
break;
}
(void)SvIOK_only(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
if (SvIsUV(sstr))
SvIsUV_on(dstr);
if (SvTAINTED(sstr))
sv_upgrade(dstr, SVt_PVNV);
break;
}
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
(void)SvNOK_only(dstr);
if (SvTAINTED(sstr))
SvTAINT(dstr);
(void)SvOOK_off(dstr); /* backoff */
if (SvLEN(dstr))
Safefree(SvPVX(dstr));
- SvLEN(dstr)=SvCUR(dstr)=0;
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
}
}
(void)SvOK_off(dstr);
- SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
+ SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
SvROK_on(dstr);
if (sflags & SVp_NOK) {
SvNOKp_on(dstr);
/* Only set the public OK flag if the source has public OK. */
if (sflags & SVf_NOK)
SvFLAGS(dstr) |= SVf_NOK;
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
(void)SvIOKp_on(dstr);
SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
}
if (SvAMAGIC(sstr)) {
SvAMAGIC_on(dstr);
SvPV_set(dstr,
sharepvn(SvPVX(sstr),
(sflags & SVf_UTF8?-cur:cur), hash));
- SvUVX(dstr) = hash;
+ SvUV_set(dstr, hash);
}
SvLEN(dstr) = len;
SvCUR(dstr) = cur;
SvNOKp_on(dstr);
if (sflags & SVf_NOK)
SvFLAGS(dstr) |= SVf_NOK;
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
(void)SvIOKp_on(dstr);
SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
}
if (SvVOK(sstr)) {
MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
/* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
if (sflags & SVp_NOK) {
if (sflags & SVf_NOK)
(void)SvNOK_on(dstr);
else
(void)SvNOKp_on(dstr);
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
}
else if (sflags & SVp_NOK) {
(void)SvOK_off(dstr);
SvNOKp_on(dstr);
}
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
}
else {
if (dtype == SVt_PVGV) {
UV hash = SvUVX(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Sharing hash\n"));
- SvUVX(dstr) = hash;
+ SvUV_set(dstr, hash);
new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
goto common_exit;
}
if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
Renew(ptr, len+1, char);
- SvPVX(sv) = ptr;
+ SvPV_set(sv, ptr);
SvCUR_set(sv, len);
SvLEN_set(sv, len+1);
*SvEND(sv) = '\0';
SvFAKE_off(sv);
SvREADONLY_off(sv);
/* This SV doesn't own the buffer, so need to New() a new one: */
- SvPVX(sv) = 0;
+ SvPV_set(sv, (char*)0);
SvLEN(sv) = 0;
if (flags & SV_COW_DROP_PV) {
/* OK, so we don't need to copy our buffer. */
U32 hash = SvUVX(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
- SvPVX(sv) = 0;
- SvLEN(sv) = 0;
+ SvPV_set(sv, (char*)0);
+ SvLEN_set(sv, 0);
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
- SvIVX(sv) = 0;
+ SvIV_set(sv, 0);
/* Same SvOOK_on but SvOOK_on does a SvIOK_off
and we do that anyway inside the SvNIOK_off
*/
SvFLAGS(sv) |= SVf_OOK;
}
SvNIOK_off(sv);
- SvLEN(sv) -= delta;
- SvCUR(sv) -= delta;
- SvPVX(sv) += delta;
- SvIVX(sv) += delta;
+ SvLEN_set(sv, SvLEN(sv) - delta);
+ SvCUR_set(sv, SvCUR(sv) - delta);
+ SvPV_set(sv, SvPVX(sv) + delta);
+ SvIV_set(sv, SvIVX(sv) + delta);
}
/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
if (sstr == dstr)
sstr = SvPVX(dsv);
Move(sstr, SvPVX(dsv) + dlen, slen, char);
- SvCUR(dsv) += slen;
+ SvCUR_set(dsv, SvCUR(dsv) + slen);
*SvEND(dsv) = '\0';
(void)SvPOK_only_UTF8(dsv); /* validate pointer */
SvTAINT(dsv);
if (ptr == junk)
ptr = SvPVX(sv);
Move(ptr,SvPVX(sv)+tlen,len+1,char);
- SvCUR(sv) += len;
+ SvCUR_set(sv, SvCUR(sv) + len);
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
=for apidoc sv_magicext
Adds magic to an SV, upgrading it if necessary. Applies the
-supplied vtable and returns pointer to the magic added.
+supplied vtable and returns a pointer to the magic added.
-Note that sv_magicext will allow things that sv_magic will not.
-In particular you can add magic to SvREADONLY SVs and and more than
-one instance of the same 'how'
+Note that C<sv_magicext> will allow things that C<sv_magic> will not.
+In particular, you can add magic to SvREADONLY SVs, and add more than
+one instance of the same 'how'.
-I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
-if C<namelen> is zero then C<name> is stored as-is and - as another special
-case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
-an C<SV*> and has its REFCNT incremented
+If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
+stored, if C<namlen> is zero then C<name> is stored as-is and - as another
+special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
+to contain an C<SV*> and is stored as-is with its REFCNT incremented.
-(This is now used as a subroutine by sv_magic.)
+(This is now used as a subroutine by C<sv_magic>.)
=cut
*/
MAGIC *
-Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
const char* name, I32 namlen)
{
MAGIC* mg;
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
- SvMAGIC(sv) = mg;
+ SvMAGIC_set(sv, mg);
- /* Some magic sontains a reference loop, where the sv and object refer to
- each other. To prevent a reference loop that would prevent such
- objects being freed, we look for such loops and if we find one we
- avoid incrementing the object refcount.
+ /* Sometimes a magic contains a reference loop, where the sv and
+ object refer to each other. To prevent a reference loop that
+ would prevent such objects being freed, we look for such loops
+ and if we find one we avoid incrementing the object refcount.
Note we cannot do this to avoid self-tie loops as intervening RV must
have its REFCNT incremented to keep it in existence.
Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
then adds a new magic item of type C<how> to the head of the magic list.
+See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
+handling of the C<name> and C<namlen> arguments.
+
+You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
+to add more than one instance of the same 'how'.
+
=cut
*/
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
+ const MGVTBL *vtable = 0;
MAGIC* mg;
- MGVTBL *vtable = 0;
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW(sv))
mgp = &SvMAGIC(sv);
for (mg = *mgp; mg; mg = *mgp) {
if (mg->mg_type == type) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
*/
void
-Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
+Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
{
register char *big;
register char *mid;
while (midend > mid) /* shove everything down */
*--bigend = *--midend;
Move(little,big+offset,littlelen,char);
- SvCUR(bigstr) += i;
+ SvCUR_set(bigstr, SvCUR(bigstr) + i);
SvSETMAGIC(bigstr);
return;
}
mg_free(nsv);
else
sv_upgrade(nsv, SVt_PVMG);
- SvMAGIC(nsv) = SvMAGIC(sv);
+ SvMAGIC_set(nsv, SvMAGIC(sv));
SvFLAGS(nsv) |= SvMAGICAL(sv);
SvMAGICAL_off(sv);
- SvMAGIC(sv) = 0;
+ SvMAGIC_set(sv, NULL);
}
SvREFCNT(sv) = 0;
sv_clear(sv);
assert(!SvREFCNT(sv));
+#ifdef DEBUG_LEAKING_SCALARS
+ sv->sv_flags = nsv->sv_flags;
+ sv->sv_any = nsv->sv_any;
+ sv->sv_refcnt = nsv->sv_refcnt;
+#else
StructCopy(nsv,sv,SV);
+#endif
+
#ifdef PERL_COPY_ON_WRITE
if (SvIsCOW_normal(nsv)) {
/* We need to follow the pointers around the loop to make the
if(SvREFCNT(tmpref) < 2) {
/* tmpref is not kept alive! */
SvREFCNT(sv)--;
- SvRV(tmpref) = 0;
+ SvRV_set(tmpref, NULL);
SvROK_off(tmpref);
}
SvREFCNT_dec(tmpref);
I32
Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
{
- char *pv1;
+ const char *pv1;
STRLEN cur1;
- char *pv2;
+ const char *pv2;
STRLEN cur2;
I32 eq = 0;
char *tpv = Nullch;
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char*)bytes_from_utf8((U8*)pv1,
+ char *pv = (char*)bytes_from_utf8((const U8*)pv1,
&cur1, &is_utf8);
if (pv != pv1)
pv1 = tpv = pv;
else {
/* sv2 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char *)bytes_from_utf8((U8*)pv2,
+ char *pv = (char *)bytes_from_utf8((const U8*)pv2,
&cur2, &is_utf8);
if (pv != pv2)
pv2 = tpv = pv;
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
STRLEN cur1, cur2;
- char *pv1, *pv2, *tpv = Nullch;
+ const char *pv1, *pv2;
+ char *tpv = Nullch;
I32 cmp;
SV *svrecode = Nullsv;
pv2 = SvPV(svrecode, cur2);
}
else {
- pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+ pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
}
}
else {
pv1 = SvPV(svrecode, cur1);
}
else {
- pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+ pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
}
}
}
} else if (!cur2) {
cmp = 1;
} else {
- I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+ const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
if (retval) {
cmp = retval < 0 ? -1 : 1;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
- char *rsptr;
+ const char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
register STDCHAR *bp;
screamer2:
if (rslen) {
- register STDCHAR *bpe = buf + sizeof(buf);
+ const register STDCHAR *bpe = buf + sizeof(buf);
bp = buf;
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
; /* keep reading */
sv_setnv(sv, UV_MAX_P1);
else
(void)SvIOK_only_UV(sv);
- ++SvUVX(sv);
+ SvUV_set(sv, SvUVX(sv) + 1);
} else {
if (SvIVX(sv) == IV_MAX)
sv_setuv(sv, (UV)IV_MAX + 1);
else {
(void)SvIOK_only(sv);
- ++SvIVX(sv);
+ SvIV_set(sv, SvIVX(sv) + 1);
}
}
return;
}
if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
- SvNVX(sv) += 1.0;
+ SvNV_set(sv, SvNVX(sv) + 1.0);
return;
}
if ((flags & SVTYPEMASK) < SVt_PVIV)
sv_upgrade(sv, SVt_IV);
(void)SvIOK_only(sv);
- SvIVX(sv) = 1;
+ SvIV_set(sv, 1);
return;
}
d = SvPVX(sv);
/* sv_2iv *should* have made this an NV */
if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
- SvNVX(sv) += 1.0;
+ SvNV_set(sv, SvNVX(sv) + 1.0);
return;
}
/* I don't think we can get here. Maybe I should assert this
}
/* oh,oh, the number grew */
SvGROW(sv, SvCUR(sv) + 2);
- SvCUR(sv)++;
+ SvCUR_set(sv, SvCUR(sv) + 1);
for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
*d = d[-1];
if (isDIGIT(d[1]))
if (SvIsUV(sv)) {
if (SvUVX(sv) == 0) {
(void)SvIOK_only(sv);
- SvIVX(sv) = -1;
+ SvIV_set(sv, -1);
}
else {
(void)SvIOK_only_UV(sv);
- --SvUVX(sv);
+ SvUV_set(sv, SvUVX(sv) + 1);
}
} else {
if (SvIVX(sv) == IV_MIN)
sv_setnv(sv, (NV)IV_MIN - 1.0);
else {
(void)SvIOK_only(sv);
- --SvIVX(sv);
+ SvIV_set(sv, SvIVX(sv) - 1);
}
}
return;
}
if (flags & SVp_NOK) {
- SvNVX(sv) -= 1.0;
+ SvNV_set(sv, SvNVX(sv) - 1.0);
(void)SvNOK_only(sv);
return;
}
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVNV)
sv_upgrade(sv, SVt_NV);
- SvNVX(sv) = -1.0;
+ SvNV_set(sv, 1.0);
(void)SvNOK_only(sv);
return;
}
/* sv_2iv *should* have made this an NV */
if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
- SvNVX(sv) -= 1.0;
+ SvNV_set(sv, SvNVX(sv) - 1.0);
return;
}
/* I don't think we can get here. Maybe I should assert this
STRLEN tmplen = -len;
is_utf8 = TRUE;
/* See the note in hv.c:hv_fetch() --jhi */
- src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+ src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
len = tmplen;
}
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
sv_upgrade(sv, SVt_PVIV);
- SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
- SvCUR(sv) = len;
- SvUVX(sv) = hash;
- SvLEN(sv) = 0;
+ SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
+ SvCUR_set(sv, len);
+ SvUV_set(sv, hash);
+ SvLEN_set(sv, 0);
SvREADONLY_on(sv);
SvFAKE_on(sv);
SvPOK_on(sv);
new_SV(sv);
sv_upgrade(sv, SVt_RV);
SvTEMP_off(tmpRef);
- SvRV(sv) = tmpRef;
+ SvRV_set(sv, tmpRef);
SvROK_on(sv);
return sv;
}
return Nullsv;
}
new_SV(sv);
- if (SvTEMP(old)) {
- SvTEMP_off(old);
- sv_setsv(sv,old);
- SvTEMP_on(old);
- }
- else
- sv_setsv(sv,old);
+ /* SV_GMAGIC is the default for sv_setv()
+ SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+ with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
+ sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
return sv;
}
*/
void
-Perl_sv_reset(pTHX_ register char *s, HV *stash)
+Perl_sv_reset(pTHX_ register const char *s, HV *stash)
{
register HE *entry;
register GV *gv;
{
IO* io;
GV* gv;
- STRLEN n_a;
switch (SvTYPE(sv)) {
case SVt_PVIO:
Perl_croak(aTHX_ PL_no_usym, "filehandle");
if (SvROK(sv))
return sv_2io(SvRV(sv));
- gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
+ gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
if (gv)
io = GvIO(gv);
else
{
GV *gv = Nullgv;
CV *cv = Nullcv;
- STRLEN n_a;
if (!sv)
return *gvp = Nullgv, Nullcv;
else if (isGV(sv))
gv = (GV*)sv;
else
- gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
+ gv = gv_fetchsv(sv, lref, SVt_PVCV);
*gvp = gv;
if (!gv)
return Nullcv;
if (!sv)
return 0;
if (SvPOK(sv)) {
- register XPV* tXpv;
+ const register XPV* tXpv;
if ((tXpv = (XPV*)SvANY(sv)) &&
(tXpv->xpv_cur > 1 ||
(tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
*/
char *
-Perl_sv_reftype(pTHX_ SV *sv, int ob)
+Perl_sv_reftype(pTHX_ const SV *sv, int ob)
{
+ /* The fact that I don't need to downcast to char * everywhere, only in ?:
+ inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- if (HvNAME(SvSTASH(sv)))
- return HvNAME(SvSTASH(sv));
- else
- return "__ANON__";
+ char *name = HvNAME(SvSTASH(sv));
+ return name ? name : (char *) "__ANON__";
}
else {
switch (SvTYPE(sv)) {
case SVt_PVNV:
case SVt_PVMG:
case SVt_PVBM:
- if (SvVOK(sv))
+ if (SvVOK(sv))
return "VSTRING";
if (SvROK(sv))
return "REF";
else
return "SCALAR";
-
- case SVt_PVLV: return SvROK(sv) ? "REF"
+
+ case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatitbility */
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
- ? "SCALAR" : "LVALUE";
+ ? "SCALAR" : "LVALUE");
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
}
SvOK_off(rv);
- SvRV(rv) = sv;
+ SvRV_set(rv, sv);
SvROK_on(rv);
if (classname) {
if (SvTYPE(tmpRef) != SVt_PVIO)
++PL_sv_objcount;
(void)SvUPGRADE(tmpRef, SVt_PVMG);
- SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
+ SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
if (SvWEAKREF(sv)) {
sv_del_backref(sv);
SvWEAKREF_off(sv);
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
return;
}
- SvRV(sv) = 0;
+ SvRV_set(sv, NULL);
SvROK_off(sv);
/* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
assigned to as BEGIN {$a = \"Foo"} will fail. */
(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
and characters >255 formatted with %c), the original SV might get
upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
-C<sv_catpvf_mg>.
+C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
+valid UTF-8; if the original SV was bytes, the pattern should be too.
=cut */
=cut
*/
+/* XXX maybe_tainted is never assigned to, so the doc above is lying. */
+
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
switch (pat[1]) {
case 's':
if (args) {
- char *s = va_arg(*args, char*);
+ const char *s = va_arg(*args, char*);
sv_catpv(sv, s ? s : nullstr);
}
else if (svix < svmax) {
#endif
char esignbuf[4];
- U8 utf8buf[UTF8_MAXLEN+1];
+ U8 utf8buf[UTF8_MAXBYTES+1];
STRLEN esignlen = 0;
char *eptr = Nullch;
STRLEN have;
STRLEN need;
STRLEN gap;
- char *dotstr = ".";
+ const char *dotstr = ".";
STRLEN dotstrlen = 1;
I32 efix = 0; /* explicit format parameter index */
I32 ewix = 0; /* explicit width index */
goto string;
case '_':
+#ifdef CHECK_FORMAT
+ format_sv:
+#endif
/*
* The "%_" hack might have to be changed someday,
* if ISO or ANSI decide to use '_' for something.
/* INTEGERS */
case 'p':
+#ifdef CHECK_FORMAT
+ if (left) {
+ left = FALSE;
+ if (!width)
+ goto format_sv; /* %-p -> %_ */
+ precis = width;
+ has_precis = TRUE;
+ width = 0;
+ goto format_sv; /* %-Np -> %.N_ */
+ }
+#endif
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
}
break;
default: /* it had better be ten or less */
-#if defined(PERL_Y2KWARN)
- if (ckWARN(WARN_Y2K)) {
- STRLEN n;
- char *s = SvPV(sv,n);
- if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
- && (n == 2 || !isDIGIT(s[n-3])))
- {
- Perl_warner(aTHX_ packWARN(WARN_Y2K),
- "Possible Y2K bug: %%%c %s",
- c, "format string following '19'");
- }
- }
-#endif
do {
dig = uv % base;
*--eptr = '0' + dig;
Copy(eptr, p, elen, char);
p += elen;
*p = '\0';
- SvCUR(sv) = p - SvPVX(sv);
+ SvCUR_set(sv, p - SvPVX(sv));
svix = osvix;
continue; /* not "break" */
}
if (has_utf8)
SvUTF8_on(sv);
*p = '\0';
- SvCUR(sv) = p - SvPVX(sv);
+ SvCUR_set(sv, p - SvPVX(sv));
if (vectorize) {
esignlen = 0;
goto vector;
ret->regstclass = NULL;
if (r->data) {
struct reg_data *d;
- int count = r->data->count;
+ const int count = r->data->count;
Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
char, struct reg_data);
for (i = 0; i < count; i++) {
d->what[i] = r->data->what[i];
switch (d->what[i]) {
+ /* legal options are one of: sfpont
+ see also regcomp.h and pregfree() */
case 's':
d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
break;
case 'o':
/* Compiled op trees are readonly, and can thus be
shared without duplication. */
+ OP_REFCNT_LOCK;
d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
+ OP_REFCNT_UNLOCK;
break;
case 'n':
d->data[i] = r->data->data[i];
break;
+ case 't':
+ d->data[i] = r->data->data[i];
+ OP_REFCNT_LOCK;
+ ((reg_trie_data*)d->data[i])->refcount++;
+ OP_REFCNT_UNLOCK;
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
}
}
Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
{
PerlIO *ret;
+ (void)type;
+
if (!fp)
return (PerlIO*)NULL;
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
- AV *av = (AV*) mg->mg_obj;
+ const AV * const av = (AV*) mg->mg_obj;
SV **svp;
I32 i;
- SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
+ (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
svp = AvARRAY(av);
for (i = AvFILLp(av); i >= 0; i--) {
if (!svp[i]) continue;
Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
{
if (SvROK(sstr)) {
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
+ SvRV_set(dstr, SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param));
+
}
else if (SvPVX(sstr)) {
/* Has something there */
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
+ SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
if (SvREADONLY(sstr) && SvFAKE(sstr)) {
/* Not that normal - actually sstr is copy on write.
But we are a true, independant SV, so: */
and they should not have these flags
turned off */
- SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
- SvUVX(sstr));
- SvUVX(dstr) = SvUVX(sstr);
+ SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
+ SvUVX(sstr)));
+ SvUV_set(dstr, SvUVX(sstr));
} else {
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+ SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
SvFAKE_off(dstr);
SvREADONLY_off(dstr);
}
}
else {
/* Some other special case - random pointer */
- SvPVX(dstr) = SvPVX(sstr);
+ SvPV_set(dstr, SvPVX(sstr));
}
}
}
else {
/* Copy the Null */
- SvPVX(dstr) = SvPVX(sstr);
+ if (SvTYPE(dstr) == SVt_RV)
+ SvRV_set(dstr, NULL);
+ else
+ SvPV_set(dstr, 0);
}
}
/* create anew and remember what it is */
new_SV(dstr);
+
+#ifdef DEBUG_LEAKING_SCALARS
+ dstr->sv_debug_optype = sstr->sv_debug_optype;
+ dstr->sv_debug_line = sstr->sv_debug_line;
+ dstr->sv_debug_inpad = sstr->sv_debug_inpad;
+ dstr->sv_debug_cloned = 1;
+# ifdef NETWARE
+ dstr->sv_debug_file = savepv(sstr->sv_debug_file);
+# else
+ dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
+# endif
+#endif
+
ptr_table_store(PL_ptr_table, sstr, dstr);
/* clone */
PL_watch_pvx, SvPVX(sstr));
#endif
+ /* don't clone objects whose class has asked us not to */
+ if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
+ SvFLAGS(dstr) &= ~SVTYPEMASK;
+ SvOBJECT_off(dstr);
+ return dstr;
+ }
+
switch (SvTYPE(sstr)) {
case SVt_NULL:
SvANY(dstr) = NULL;
break;
case SVt_IV:
SvANY(dstr) = new_XIV();
- SvIVX(dstr) = SvIVX(sstr);
+ SvIV_set(dstr, SvIVX(sstr));
break;
case SVt_NV:
SvANY(dstr) = new_XNV();
- SvNVX(dstr) = SvNVX(sstr);
+ SvNV_set(dstr, SvNVX(sstr));
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVIV:
SvANY(dstr) = new_XPVIV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVNV:
SvANY(dstr) = new_XPVNV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVMG:
SvANY(dstr) = new_XPVMG();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVBM:
SvANY(dstr) = new_XPVBM();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
BmRARE(dstr) = BmRARE(sstr);
BmUSEFUL(dstr) = BmUSEFUL(sstr);
break;
case SVt_PVLV:
SvANY(dstr) = new_XPVLV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
}
}
SvANY(dstr) = new_XPVGV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
break;
case SVt_PVIO:
SvANY(dstr) = new_XPVIO();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
if (IoOFP(sstr) == IoIFP(sstr))
break;
case SVt_PVAV:
SvANY(dstr) = new_XPVAV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
if (AvARRAY((AV*)sstr)) {
src_ary = AvARRAY((AV*)sstr);
Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
ptr_table_store(PL_ptr_table, src_ary, dst_ary);
- SvPVX(dstr) = (char*)dst_ary;
+ SvPV_set(dstr, (char*)dst_ary);
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
while (items-- > 0)
}
}
else {
- SvPVX(dstr) = Nullch;
+ SvPV_set(dstr, Nullch);
AvALLOC((AV*)dstr) = (SV**)NULL;
}
break;
case SVt_PVHV:
SvANY(dstr) = new_XPVHV();
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
if (HvARRAY((HV*)sstr)) {
STRLEN i = 0;
(bool)!!HvSHAREKEYS(sstr), param);
}
else {
- SvPVX(dstr) = Nullch;
+ SvPV_set(dstr, Nullch);
HvEITER((HV*)dstr) = (HE*)NULL;
}
HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
case SVt_PVCV:
SvANY(dstr) = new_XPVCV();
dup_pvcv:
- SvCUR(dstr) = SvCUR(sstr);
- SvLEN(dstr) = SvLEN(sstr);
- SvIVX(dstr) = SvIVX(sstr);
- SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvIV_set(dstr, SvIVX(sstr));
+ SvNV_set(dstr, SvNVX(sstr));
+ SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
+ SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
+ OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
+ OP_REFCNT_UNLOCK;
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
if (CvCONST(sstr)) {
CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
- sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
+ sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
}
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
return nss;
}
+
+/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
+ * flag to the result. This is done for each stash before cloning starts,
+ * so we know which stashes want their objects cloned */
+
+static void
+do_mark_cloneable_stash(pTHX_ SV *sv)
+{
+ if (HvNAME((HV*)sv)) {
+ GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
+ SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ UV status;
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
+ PUTBACK;
+ call_sv((SV*)GvCV(cloner), G_SCALAR);
+ SPAGAIN;
+ status = POPu;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (status)
+ SvFLAGS(sv) &= ~SVphv_CLONEABLE;
+ }
+ }
+}
+
+
+
/*
=for apidoc perl_clone
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
CLONE_PARAMS clone_params;
CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ /* for each stash, determine whether its objects should be cloned */
+ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
PERL_SET_THX(my_perl);
-
-
# ifdef DEBUGGING
Poison(my_perl, 1, PerlInterpreter);
+ PL_op = Nullop;
+ PL_curcop = (COP *)Nullop;
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
SvANY(&PL_sv_no) = new_XPVNV();
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
- SvCUR(&PL_sv_no) = 0;
- SvLEN(&PL_sv_no) = 1;
- SvNVX(&PL_sv_no) = 0;
+ SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
+ SvCUR_set(&PL_sv_no, 0);
+ SvLEN_set(&PL_sv_no, 1);
+ SvIV_set(&PL_sv_no, 0);
+ SvNV_set(&PL_sv_no, 0);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
SvANY(&PL_sv_yes) = new_XPVNV();
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
- SvCUR(&PL_sv_yes) = 1;
- SvLEN(&PL_sv_yes) = 2;
- SvNVX(&PL_sv_yes) = 1;
+ SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
+ SvCUR_set(&PL_sv_yes, 1);
+ SvLEN_set(&PL_sv_yes, 2);
+ SvIV_set(&PL_sv_yes, 1);
+ SvNV_set(&PL_sv_yes, 1);
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
/* create (a non-shared!) shared string table */
PL_dirty = proto_perl->Tdirty;
PL_localizing = proto_perl->Tlocalizing;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- PL_protect = proto_perl->Tprotect;
-#endif
PL_errors = sv_dup_inc(proto_perl->Terrors, param);
PL_hv_fetch_ent_mh = Nullhe;
PL_modcount = proto_perl->Tmodcount;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
+ XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_DISCARD);
FREETMPS;
return ret;
}
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/
https://perl5.git.perl.org / perl5.git / blobdiff