/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
called by visit() for each SV]):
sv_report_used() / do_report_used()
- dump all remaining SVs (debugging aid)
+ dump all remaining SVs (debugging aid)
sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
Attempt to free all objects pointed to by RVs,
void
Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
{
+ dVAR;
void *new_chunk;
U32 new_chunk_size;
LOCK_SV_MUTEX;
STATIC SV*
S_more_sv(pTHX)
{
+ dVAR;
SV* sv;
if (PL_nice_chunk) {
STATIC void
S_del_sv(pTHX_ SV *p)
{
+ dVAR;
if (DEBUG_D_TEST) {
SV* sva;
bool ok = 0;
void
Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
{
+ dVAR;
SV* const sva = (SV*)ptr;
register SV* sv;
register SV* svend;
STATIC I32
S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
{
+ dVAR;
SV* sva;
I32 visited = 0;
static void
do_clean_objs(pTHX_ SV *ref)
{
+ dVAR;
if (SvROK(ref)) {
SV * const target = SvRV(ref);
if (SvOBJECT(target)) {
static void
do_clean_named_objs(pTHX_ SV *sv)
{
+ dVAR;
if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
if ((
#ifdef PERL_DONT_CREATE_GVSV
void
Perl_sv_clean_objs(pTHX)
{
+ dVAR;
PL_in_clean_objs = TRUE;
visit(do_clean_objs, SVf_ROK, SVf_ROK);
#ifndef DISABLE_DESTRUCTOR_KLUDGE
static void
do_clean_all(pTHX_ SV *sv)
{
+ dVAR;
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
if (PL_comppad == (AV*)sv) {
I32
Perl_sv_clean_all(pTHX)
{
+ dVAR;
I32 cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
void
Perl_sv_free_arenas(pTHX)
{
+ dVAR;
SV* sva;
SV* svanext;
int i;
STATIC void *
S_more_bodies (pTHX_ size_t size, svtype sv_type)
{
+ dVAR;
void ** const arena_root = &PL_body_arenaroots[sv_type];
void ** const root = &PL_body_roots[sv_type];
char *start;
STATIC void *
S_new_body(pTHX_ size_t size, svtype sv_type)
{
+ dVAR;
void *xpv;
new_body_inline(xpv, size, sv_type);
return xpv;
void
Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
{
+ dVAR;
void* old_body;
void* new_body;
const U32 old_type = SvTYPE(sv);
/* Could put this in the else clause below, as PVMG must have SvPVX
0 already (the assertion above) */
- SvPV_set(sv, (char*)0);
+ SvPV_set(sv, NULL);
if (old_type >= SVt_PVMG) {
SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
} else {
- SvMAGIC_set(sv, 0);
- SvSTASH_set(sv, 0);
+ SvMAGIC_set(sv, NULL);
+ SvSTASH_set(sv, NULL);
}
break;
}
#ifndef NV_ZERO_IS_ALLBITS_ZERO
- /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
- 0.0 for us. */
- if (old_type_details->zero_nv)
+ /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
+ * correct 0.0 for us. Otherwise, if the old body didn't have an
+ * NV slot, but the new one does, then we need to initialise the
+ * freshly created NV slot with whatever the correct bit pattern is
+ * for 0.0 */
+ if (old_type_details->zero_nv && !new_type_details->zero_nv)
SvNV_set(sv, 0);
#endif
if (new_type == SVt_PVIO)
- IoPAGE_LEN(sv) = 60;
+ IoPAGE_LEN(sv) = 60;
if (old_type < SVt_RV)
- SvPV_set(sv, 0);
+ SvPV_set(sv, NULL);
break;
default:
- Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
+ Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
+ (unsigned long)new_type);
}
if (old_type_details->size) {
void
Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
+ dVAR;
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
void
Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
+ dVAR;
SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
+ dVAR;
SV *dsv;
char tmpbuf[64];
const char *pv;
if (DO_UTF8(sv)) {
- dsv = sv_2mortal(newSVpvn("", 0));
+ dsv = sv_2mortal(newSVpvs(""));
pv = sv_uni_display(dsv, sv, 10, 0);
} else {
char *d = tmpbuf;
STATIC int
S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
+ dVAR;
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
STATIC bool
S_sv_2iuv_common(pTHX_ SV *sv) {
+ dVAR;
if (SvNOKp(sv)) {
/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
* without also getting a cached IV/UV from it at the same time
} else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- /* If NV preserves UV then we only use the UV value if we know that
+ /* If NVs preserve UVs then we only use the UV value if we know that
we aren't going to call atof() below. If NVs don't preserve UVs
then the value returned may have more precision than atof() will
return, even though value isn't perfectly accurate. */
IV
Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
{
+ dVAR;
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
UV
Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
{
+ dVAR;
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
NV
Perl_sv_2nv(pTHX_ register SV *sv)
{
+ dVAR;
if (!sv)
return 0.0;
if (SvGMAGICAL(sv)) {
static char *
S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
+ dVAR;
const regexp * const re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
char *
Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
{
+ dVAR;
register char *s;
if (!sv) {
const SV *const referent = (SV*)SvRV(sv);
if (!referent) {
- tsv = sv_2mortal(newSVpvn("NULLREF", 7));
+ tsv = sv_2mortal(newSVpvs("NULLREF"));
} else if (SvTYPE(referent) == SVt_PVMG
&& ((SvFLAGS(referent) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
bool
Perl_sv_2bool(pTHX_ register SV *sv)
{
+ dVAR;
SvGETMAGIC(sv);
if (!SvOK(sv))
STRLEN
Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
{
+ dVAR;
if (sv == &PL_sv_undef)
return 0;
if (!SvPOK(sv)) {
bool
Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
{
+ dVAR;
if (SvPOKp(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
U8 *s;
=cut
*/
+static void
+S_glob_assign(pTHX_ SV *dstr, SV *sstr, const int dtype)
+{
+ if (dtype != SVt_PVGV) {
+ const char * const name = GvNAME(sstr);
+ const STRLEN len = GvNAMELEN(sstr);
+ /* don't upgrade SVt_PVLV: it can hold a glob */
+ if (dtype != SVt_PVLV)
+ sv_upgrade(dstr, SVt_PVGV);
+ sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
+ GvSTASH(dstr) = GvSTASH(sstr);
+ if (GvSTASH(dstr))
+ Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
+ GvNAME(dstr) = savepvn(name, len);
+ GvNAMELEN(dstr) = len;
+ SvFAKE_on(dstr); /* can coerce to non-glob */
+ }
+
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
+ (void)SvOK_off(dstr);
+ GvINTRO_off(dstr); /* one-shot flag */
+ gp_free((GV*)dstr);
+ GvGP(dstr) = gp_ref(GvGP(sstr));
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
+ if (GvIMPORTED(dstr) != GVf_IMPORTED
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+ {
+ GvIMPORTED_on(dstr);
+ }
+ GvMULTI_on(dstr);
+ return;
+}
+
+static void
+S_pvgv_assign(pTHX_ SV *dstr, SV *sstr) {
+ SV * const sref = SvREFCNT_inc(SvRV(sstr));
+ SV *dref = NULL;
+ const int intro = GvINTRO(dstr);
+
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
+ if (intro) {
+ GvINTRO_off(dstr); /* one-shot flag */
+ GvLINE(dstr) = CopLINE(PL_curcop);
+ GvEGV(dstr) = (GV*)dstr;
+ }
+ GvMULTI_on(dstr);
+ switch (SvTYPE(sref)) {
+ case SVt_PVAV:
+ if (intro)
+ SAVEGENERICSV(GvAV(dstr));
+ else
+ dref = (SV*)GvAV(dstr);
+ GvAV(dstr) = (AV*)sref;
+ if (!GvIMPORTED_AV(dstr)
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+ {
+ GvIMPORTED_AV_on(dstr);
+ }
+ break;
+ case SVt_PVHV:
+ if (intro)
+ SAVEGENERICSV(GvHV(dstr));
+ else
+ dref = (SV*)GvHV(dstr);
+ GvHV(dstr) = (HV*)sref;
+ if (!GvIMPORTED_HV(dstr)
+ && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
+ {
+ GvIMPORTED_HV_on(dstr);
+ }
+ break;
+ case SVt_PVCV:
+ if (intro) {
+ if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
+ SvREFCNT_dec(GvCV(dstr));
+ GvCV(dstr) = Nullcv;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ PL_sub_generation++;
+ }
+ SAVEGENERICSV(GvCV(dstr));
+ }
+ else
+ dref = (SV*)GvCV(dstr);
+ if (GvCV(dstr) != (CV*)sref) {
+ CV* const cv = GvCV(dstr);
+ if (cv) {
+ if (!GvCVGEN((GV*)dstr) &&
+ (CvROOT(cv) || CvXSUB(cv)))
+ {
+ /* Redefining a sub - warning is mandatory if
+ it was a const and its value changed. */
+ if (CvCONST(cv) && CvCONST((CV*)sref)
+ && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
+ /* They are 2 constant subroutines generated from
+ the same constant. This probably means that
+ they are really the "same" proxy subroutine
+ instantiated in 2 places. Most likely this is
+ when a constant is exported twice. Don't warn.
+ */
+ }
+ else if (ckWARN(WARN_REDEFINE)
+ || (CvCONST(cv)
+ && (!CvCONST((CV*)sref)
+ || sv_cmp(cv_const_sv(cv),
+ cv_const_sv((CV*)sref))))) {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ CvCONST(cv)
+ ? "Constant subroutine %s::%s redefined"
+ : "Subroutine %s::%s redefined",
+ HvNAME_get(GvSTASH((GV*)dstr)),
+ GvENAME((GV*)dstr));
+ }
+ }
+ if (!intro)
+ cv_ckproto(cv, (GV*)dstr,
+ SvPOK(sref) ? SvPVX_const(sref) : Nullch);
+ }
+ GvCV(dstr) = (CV*)sref;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ GvASSUMECV_on(dstr);
+ PL_sub_generation++;
+ }
+ if (!GvIMPORTED_CV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
+ GvIMPORTED_CV_on(dstr);
+ }
+ break;
+ case SVt_PVIO:
+ if (intro)
+ SAVEGENERICSV(GvIOp(dstr));
+ else
+ dref = (SV*)GvIOp(dstr);
+ GvIOp(dstr) = (IO*)sref;
+ break;
+ case SVt_PVFM:
+ if (intro)
+ SAVEGENERICSV(GvFORM(dstr));
+ else
+ dref = (SV*)GvFORM(dstr);
+ GvFORM(dstr) = (CV*)sref;
+ break;
+ default:
+ if (intro)
+ SAVEGENERICSV(GvSV(dstr));
+ else
+ dref = (SV*)GvSV(dstr);
+ GvSV(dstr) = sref;
+ if (!GvIMPORTED_SV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
+ GvIMPORTED_SV_on(dstr);
+ }
+ break;
+ }
+ if (dref)
+ SvREFCNT_dec(dref);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
+ return;
+}
+
void
Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
{
+ dVAR;
register U32 sflags;
register int dtype;
register int stype;
SvIV_set(dstr, SvIVX(sstr));
if (SvIsUV(sstr))
SvIsUV_on(dstr);
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
+ /* SvTAINTED can only be true if the SV has taint magic, which in
+ turn means that the SV type is PVMG (or greater). This is the
+ case statement for SVt_IV, so this cannot be true (whatever gcov
+ may say). */
+ assert(!SvTAINTED(sstr));
return;
}
goto undef_sstr;
}
SvNV_set(dstr, SvNVX(sstr));
(void)SvNOK_only(dstr);
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
+ /* SvTAINTED can only be true if the SV has taint magic, which in
+ turn means that the SV type is PVMG (or greater). This is the
+ case statement for SVt_NV, so this cannot be true (whatever gcov
+ may say). */
+ assert(!SvTAINTED(sstr));
return;
}
goto undef_sstr;
GvMULTI_on(dstr);
return;
}
- goto glob_assign;
+ S_glob_assign(aTHX_ dstr, sstr, dtype);
+ return;
}
break;
case SVt_PVFM:
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
- glob_assign:
- if (dtype != SVt_PVGV) {
- const char * const name = GvNAME(sstr);
- const STRLEN len = GvNAMELEN(sstr);
- /* don't upgrade SVt_PVLV: it can hold a glob */
- if (dtype != SVt_PVLV)
- sv_upgrade(dstr, SVt_PVGV);
- sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
- GvSTASH(dstr) = GvSTASH(sstr);
- if (GvSTASH(dstr))
- Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
- GvNAME(dstr) = savepvn(name, len);
- GvNAMELEN(dstr) = len;
- SvFAKE_on(dstr); /* can coerce to non-glob */
- }
-
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)dstr)) {
- Perl_croak(aTHX_ PL_no_modify);
- }
-#endif
-
- (void)SvOK_off(dstr);
- GvINTRO_off(dstr); /* one-shot flag */
- gp_free((GV*)dstr);
- GvGP(dstr) = gp_ref(GvGP(sstr));
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
- if (GvIMPORTED(dstr) != GVf_IMPORTED
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_on(dstr);
- }
- GvMULTI_on(dstr);
+ S_glob_assign(aTHX_ dstr, sstr, dtype);
return;
}
/* FALL THROUGH */
mg_get(sstr);
if ((int)SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
- if (stype == SVt_PVGV && dtype <= SVt_PVGV)
- goto glob_assign;
+ if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
+ S_glob_assign(aTHX_ dstr, sstr, dtype);
+ return;
+ }
}
}
if (stype == SVt_PVLV)
if (sflags & SVf_ROK) {
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
- SV * const sref = SvREFCNT_inc(SvRV(sstr));
- SV *dref = 0;
- const int intro = GvINTRO(dstr);
-
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE((GV*)dstr)) {
- Perl_croak(aTHX_ PL_no_modify);
- }
-#endif
-
- if (intro) {
- GvINTRO_off(dstr); /* one-shot flag */
- GvLINE(dstr) = CopLINE(PL_curcop);
- GvEGV(dstr) = (GV*)dstr;
- }
- GvMULTI_on(dstr);
- switch (SvTYPE(sref)) {
- case SVt_PVAV:
- if (intro)
- SAVEGENERICSV(GvAV(dstr));
- else
- dref = (SV*)GvAV(dstr);
- GvAV(dstr) = (AV*)sref;
- if (!GvIMPORTED_AV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_AV_on(dstr);
- }
- break;
- case SVt_PVHV:
- if (intro)
- SAVEGENERICSV(GvHV(dstr));
- else
- dref = (SV*)GvHV(dstr);
- GvHV(dstr) = (HV*)sref;
- if (!GvIMPORTED_HV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_HV_on(dstr);
- }
- break;
- case SVt_PVCV:
- if (intro) {
- if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
- SvREFCNT_dec(GvCV(dstr));
- GvCV(dstr) = Nullcv;
- GvCVGEN(dstr) = 0; /* Switch off cacheness. */
- PL_sub_generation++;
- }
- SAVEGENERICSV(GvCV(dstr));
- }
- else
- dref = (SV*)GvCV(dstr);
- if (GvCV(dstr) != (CV*)sref) {
- CV* const cv = GvCV(dstr);
- if (cv) {
- if (!GvCVGEN((GV*)dstr) &&
- (CvROOT(cv) || CvXSUB(cv)))
- {
- /* Redefining a sub - warning is mandatory if
- it was a const and its value changed. */
- if (CvCONST(cv) && CvCONST((CV*)sref)
- && cv_const_sv(cv)
- == cv_const_sv((CV*)sref)) {
- /* They are 2 constant subroutines
- generated from the same constant.
- This probably means that they are
- really the "same" proxy subroutine
- instantiated in 2 places. Most likely
- this is when a constant is exported
- twice. Don't warn. */
- }
- else if (ckWARN(WARN_REDEFINE)
- || (CvCONST(cv)
- && (!CvCONST((CV*)sref)
- || sv_cmp(cv_const_sv(cv),
- cv_const_sv((CV*)sref)))))
- {
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv)
- ? "Constant subroutine %s::%s redefined"
- : "Subroutine %s::%s redefined",
- HvNAME_get(GvSTASH((GV*)dstr)),
- GvENAME((GV*)dstr));
- }
- }
- if (!intro)
- cv_ckproto(cv, (GV*)dstr,
- SvPOK(sref)
- ? SvPVX_const(sref) : Nullch);
- }
- GvCV(dstr) = (CV*)sref;
- GvCVGEN(dstr) = 0; /* Switch off cacheness. */
- GvASSUMECV_on(dstr);
- PL_sub_generation++;
- }
- if (!GvIMPORTED_CV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_CV_on(dstr);
- }
- break;
- case SVt_PVIO:
- if (intro)
- SAVEGENERICSV(GvIOp(dstr));
- else
- dref = (SV*)GvIOp(dstr);
- GvIOp(dstr) = (IO*)sref;
- break;
- case SVt_PVFM:
- if (intro)
- SAVEGENERICSV(GvFORM(dstr));
- else
- dref = (SV*)GvFORM(dstr);
- GvFORM(dstr) = (CV*)sref;
- break;
- default:
- if (intro)
- SAVEGENERICSV(GvSV(dstr));
- else
- dref = (SV*)GvSV(dstr);
- GvSV(dstr) = sref;
- if (!GvIMPORTED_SV(dstr)
- && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
- {
- GvIMPORTED_SV_on(dstr);
- }
- break;
- }
- if (dref)
- SvREFCNT_dec(dref);
- if (SvTAINTED(sstr))
- SvTAINT(dstr);
+ S_pvgv_assign(aTHX_ dstr, sstr);
return;
}
if (SvPVX_const(dstr)) {
}
(void)SvOK_off(dstr);
SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
- SvROK_on(dstr);
+ SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_ROK
+ |SVf_AMAGIC);
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;
SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
- (void)SvIOKp_on(dstr);
- if (sflags & SVf_IOK)
- SvFLAGS(dstr) |= SVf_IOK;
+ /* Must do this otherwise some other overloaded use of 0x80000000
+ gets confused. Probably 0x80000000 */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
SvIV_set(dstr, SvIVX(sstr));
}
- if (SvAMAGIC(sstr)) {
- SvAMAGIC_on(dstr);
- }
}
else if (sflags & SVp_POK) {
bool isSwipe = 0;
SvTEMP_off(dstr);
(void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
- SvPV_set(sstr, Nullch);
+ SvPV_set(sstr, NULL);
SvLEN_set(sstr, 0);
SvCUR_set(sstr, 0);
SvTEMP_off(sstr);
}
}
- if (sflags & SVf_UTF8)
- SvUTF8_on(dstr);
if (sflags & SVp_NOK) {
- SvNOKp_on(dstr);
- if (sflags & SVf_NOK)
- SvFLAGS(dstr) |= SVf_NOK;
SvNV_set(dstr, SvNVX(sstr));
}
if (sflags & SVp_IOK) {
- (void)SvIOKp_on(dstr);
- if (sflags & SVf_IOK)
- SvFLAGS(dstr) |= SVf_IOK;
+ SvRELEASE_IVX(dstr);
+ SvIV_set(dstr, SvIVX(sstr));
+ /* Must do this otherwise some other overloaded use of 0x80000000
+ gets confused. I guess SVpbm_VALID */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- SvIV_set(dstr, SvIVX(sstr));
}
- if (SvVOK(sstr)) {
- const MAGIC * const smg = mg_find(sstr,PERL_MAGIC_vstring);
- sv_magic(dstr, NULL, PERL_MAGIC_vstring,
- smg->mg_ptr, smg->mg_len);
- SvRMAGICAL_on(dstr);
+ SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
+ {
+ const MAGIC * const smg = SvVOK(sstr);
+ if (smg) {
+ sv_magic(dstr, NULL, PERL_MAGIC_vstring,
+ smg->mg_ptr, smg->mg_len);
+ SvRMAGICAL_on(dstr);
+ }
}
}
- else if (sflags & SVp_IOK) {
- if (sflags & SVf_IOK)
- (void)SvIOK_only(dstr);
- else {
- (void)SvOK_off(dstr);
- (void)SvIOKp_on(dstr);
+ else if (sflags & (SVp_IOK|SVp_NOK)) {
+ (void)SvOK_off(dstr);
+ SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
+ if (sflags & SVp_IOK) {
+ /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
+ SvIV_set(dstr, SvIVX(sstr));
}
- /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
- if (sflags & SVf_IVisUV)
- SvIsUV_on(dstr);
- SvIV_set(dstr, SvIVX(sstr));
if (sflags & SVp_NOK) {
- if (sflags & SVf_NOK)
- (void)SvNOK_on(dstr);
- else
- (void)SvNOKp_on(dstr);
+ SvFLAGS(dstr) |= sflags & (SVf_NOK|SVp_NOK);
SvNV_set(dstr, SvNVX(sstr));
}
}
- else if (sflags & SVp_NOK) {
- if (sflags & SVf_NOK)
- (void)SvNOK_only(dstr);
- else {
- (void)SvOK_off(dstr);
- SvNOKp_on(dstr);
- }
- SvNV_set(dstr, SvNVX(sstr));
- }
else {
if (dtype == SVt_PVGV) {
if (ckWARN(WARN_MISC))
void
Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
+ dVAR;
register char *dptr;
SV_CHECK_THINKFIRST_COW_DROP(sv);
void
Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
{
+ dVAR;
register STRLEN len;
SV_CHECK_THINKFIRST_COW_DROP(sv);
void
Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
+ dVAR;
STRLEN allocate;
SV_CHECK_THINKFIRST_COW_DROP(sv);
SvUPGRADE(sv, SVt_PV);
void
Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
+ dVAR;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
/* At this point I believe I should acquire a global SV mutex. */
SvFAKE_off(sv);
SvREADONLY_off(sv);
/* This SV doesn't own the buffer, so need to Newx() a new one: */
- SvPV_set(sv, (char*)0);
+ SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
/* OK, so we don't need to copy our buffer. */
void
Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
{
+ dVAR;
STRLEN dlen;
const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
void
Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
{
+ dVAR;
if (ssv) {
STRLEN slen;
const char *spv = SvPV_const(ssv, slen);
void
Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
{
+ dVAR;
register STRLEN len;
STRLEN tlen;
char *junk;
/*
=for apidoc newSV
-Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
-with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
-macro.
+Creates a new SV. A non-zero C<len> parameter indicates the number of
+bytes of preallocated string space the SV should have. An extra byte for a
+trailing NUL is also reserved. (SvPOK is not set for the SV even if string
+space is allocated.) The reference count for the new SV is set to 1.
+
+In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
+parameter, I<x>, a debug aid which allowed callers to identify themselves.
+This aid has been superseded by a new build option, PERL_MEM_LOG (see
+L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
+modules supporting older perls.
=cut
*/
SV *
Perl_newSV(pTHX_ STRLEN len)
{
+ dVAR;
register SV *sv;
new_SV(sv);
=cut
*/
MAGIC *
-Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
const char* name, I32 namlen)
{
+ dVAR;
MAGIC* mg;
if (SvTYPE(sv) < SVt_PVMG) {
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
- const MGVTBL *vtable;
+ dVAR;
+ MGVTBL *vtable;
MAGIC* mg;
#ifdef PERL_OLD_COPY_ON_WRITE
}
if (!SvMAGIC(sv)) {
SvMAGICAL_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvMAGIC_set(sv, NULL);
}
return 0;
void
Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
+ dVAR;
AV *av;
- MAGIC *mg;
- if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
- av = (AV*)mg->mg_obj;
- else {
- av = newAV();
- AvREAL_off(av);
- sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
- /* av now has a refcnt of 2, which avoids it getting freed
- * before us during global cleanup. The extra ref is removed
- * by magic_killbackrefs() when tsv is being freed */
+
+ if (SvTYPE(tsv) == SVt_PVHV) {
+ AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+
+ av = *avp;
+ if (!av) {
+ /* There is no AV in the offical place - try a fixup. */
+ MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
+
+ if (mg) {
+ /* Aha. They've got it stowed in magic. Bring it back. */
+ av = (AV*)mg->mg_obj;
+ /* Stop mg_free decreasing the refernce count. */
+ mg->mg_obj = NULL;
+ /* Stop mg_free even calling the destructor, given that
+ there's no AV to free up. */
+ mg->mg_virtual = 0;
+ sv_unmagic(tsv, PERL_MAGIC_backref);
+ } else {
+ av = newAV();
+ AvREAL_off(av);
+ SvREFCNT_inc(av);
+ }
+ *avp = av;
+ }
+ } else {
+ const MAGIC *const mg
+ = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
+ if (mg)
+ av = (AV*)mg->mg_obj;
+ else {
+ av = newAV();
+ AvREAL_off(av);
+ sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
+ /* av now has a refcnt of 2, which avoids it getting freed
+ * before us during global cleanup. The extra ref is removed
+ * by magic_killbackrefs() when tsv is being freed */
+ }
}
if (AvFILLp(av) >= AvMAX(av)) {
av_extend(av, AvFILLp(av)+1);
STATIC void
S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
{
- AV *av;
+ dVAR;
+ AV *av = NULL;
SV **svp;
I32 i;
- MAGIC *mg = NULL;
- if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
+
+ if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
+ av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
+ /* We mustn't attempt to "fix up" the hash here by moving the
+ backreference array back to the hv_aux structure, as that is stored
+ in the main HvARRAY(), and hfreentries assumes that no-one
+ reallocates HvARRAY() while it is running. */
+ }
+ if (!av) {
+ const MAGIC *const mg
+ = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
+ if (mg)
+ av = (AV *)mg->mg_obj;
+ }
+ if (!av) {
if (PL_in_clean_all)
return;
- }
- if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
- av = (AV *)mg->mg_obj;
+ }
+
+ if (SvIS_FREED(av))
+ return;
+
svp = AvARRAY(av);
/* We shouldn't be in here more than once, but for paranoia reasons lets
not assume this. */
}
}
+int
+Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
+{
+ SV **svp = AvARRAY(av);
+
+ PERL_UNUSED_ARG(sv);
+
+ /* Not sure why the av can get freed ahead of its sv, but somehow it does
+ in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
+ if (svp && !SvIS_FREED(av)) {
+ SV *const *const last = svp + AvFILLp(av);
+
+ while (svp <= last) {
+ if (*svp) {
+ SV *const referrer = *svp;
+ if (SvWEAKREF(referrer)) {
+ /* XXX Should we check that it hasn't changed? */
+ SvRV_set(referrer, 0);
+ SvOK_off(referrer);
+ SvWEAKREF_off(referrer);
+ } else if (SvTYPE(referrer) == SVt_PVGV ||
+ SvTYPE(referrer) == SVt_PVLV) {
+ /* You lookin' at me? */
+ assert(GvSTASH(referrer));
+ assert(GvSTASH(referrer) == (HV*)sv);
+ GvSTASH(referrer) = 0;
+ } else {
+ Perl_croak(aTHX_
+ "panic: magic_killbackrefs (flags=%"UVxf")",
+ (UV)SvFLAGS(referrer));
+ }
+
+ *svp = Nullsv;
+ }
+ svp++;
+ }
+ }
+ SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
+ return 0;
+}
+
/*
=for apidoc sv_insert
void
Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
{
+ dVAR;
register char *big;
register char *mid;
register char *midend;
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
+ dVAR;
const U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST_COW_DROP(sv);
if (SvREFCNT(nsv) != 1) {
cv_undef((CV*)sv);
goto freescalar;
case SVt_PVHV:
+ Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
hv_undef((HV*)sv);
break;
case SVt_PVAV:
start = (U8*)SvPV_const(sv, len);
if (len) {
STRLEN boffset = 0;
- STRLEN *cache = 0;
+ STRLEN *cache = NULL;
const U8 *s = start;
I32 uoffset = *offsetp;
const U8 * const send = s + len;
- MAGIC *mg = 0;
- bool found = FALSE;
+ MAGIC *mg = NULL;
+ bool found = utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send);
- if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
- found = TRUE;
if (!found && uoffset > 0) {
while (s < send && uoffset--)
s += UTF8SKIP(s);
I32
Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
const char *pv1;
STRLEN cur1;
const char *pv2;
I32
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
char *tpv = Nullch;
I32
Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
#ifdef USE_LOCALE_COLLATE
char *pv1, *pv2;
char *
Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
{
+ dVAR;
MAGIC *mg;
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
+ dVAR;
const char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
sv_pos_u2b(sv,&append,0);
}
} else if (SvUTF8(sv)) {
- SV * const tsv = NEWSV(0,0);
+ SV * const tsv = newSV(0);
sv_gets(tsv, fp, 0);
sv_utf8_upgrade_nomg(tsv);
SvCUR_set(sv,append);
{
/*The big, slow, and stupid way. */
#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
- STDCHAR *buf = 0;
+ STDCHAR *buf = NULL;
Newx(buf, 8192, STDCHAR);
assert(buf);
#else
void
Perl_sv_inc(pTHX_ register SV *sv)
{
+ dVAR;
register char *d;
int flags;
void
Perl_sv_dec(pTHX_ register SV *sv)
{
+ dVAR;
int flags;
if (!sv)
SV *
Perl_sv_mortalcopy(pTHX_ SV *oldstr)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_sv_newmortal(pTHX)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVpv(pTHX_ const char *s, STRLEN len)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVhek(pTHX_ const HEK *hek)
{
+ dVAR;
if (!hek) {
SV *sv;
SV *
Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
{
+ dVAR;
register SV *sv;
bool is_utf8 = FALSE;
if (len < 0) {
SV *
Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
{
+ dVAR;
register SV *sv;
new_SV(sv);
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
SV *
Perl_newSVnv(pTHX_ NV n)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSViv(pTHX_ IV i)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newSVuv(pTHX_ UV u)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
+ dVAR;
register SV *sv;
new_SV(sv);
SV *
Perl_newRV(pTHX_ SV *tmpRef)
{
+ dVAR;
return newRV_noinc(SvREFCNT_inc(tmpRef));
}
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
+ dVAR;
register SV *sv;
if (!old)
if (lref && !GvCVu(gv)) {
SV *tmpsv;
ENTER;
- tmpsv = NEWSV(704,0);
+ tmpsv = newSV(0);
gv_efullname3(tmpsv, gv, Nullch);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
char *
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
-
+ dVAR;
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal_flags(sv, 0);
SV*
Perl_newSVrv(pTHX_ SV *rv, const char *classname)
{
+ dVAR;
SV *sv;
new_SV(sv);
SV*
Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
{
+ dVAR;
if (!pv) {
sv_setsv(rv, &PL_sv_undef);
SvSETMAGIC(rv);
SV*
Perl_sv_bless(pTHX_ SV *sv, HV *stash)
{
+ dVAR;
SV *tmpRef;
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
STATIC void
S_sv_unglob(pTHX_ SV *sv)
{
+ dVAR;
void *xpvmg;
assert(SvTYPE(sv) == SVt_PVGV);
STATIC I32
S_expect_number(pTHX_ char** pattern)
{
+ dVAR;
I32 var = 0;
switch (**pattern) {
case '1': case '2': case '3':
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
+ dVAR;
char *p;
char *q;
const char *patend;
*/
if (sv_derived_from(vecsv, "version")) {
char *version = savesvpv(vecsv);
+ if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "vector argument not supported with alpha versions");
+ goto unknown;
+ }
vecsv = sv_newmortal();
/* scan_vstring is expected to be called during
* tokenization, so we need to fake up the end
"\"%%\\%03"UVof"\"",
(UV)c & 0xFF);
} else
- sv_catpv(msg, "end of string");
+ sv_catpvs(msg, "end of string");
Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
}
#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
-#define SAVEPV(p) (p ? savepv(p) : Nullch)
-#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
+#define SAVEPV(p) ((p) ? savepv(p) : NULL)
+#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
}
else if(mg->mg_type == PERL_MAGIC_backref) {
- const AV * const av = (AV*) mg->mg_obj;
- SV **svp;
- I32 i;
- (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
- AvREAL_off((AV*)nmg->mg_obj);
- svp = AvARRAY(av);
- for (i = AvFILLp(av); i >= 0; i--) {
- if (!svp[i]) continue;
- av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
- }
+ /* The backref AV has its reference count deliberately bumped by
+ 1. */
+ nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
}
else if (mg->mg_type == PERL_MAGIC_symtab) {
nmg->mg_obj = mg->mg_obj;
if (SvTYPE(dstr) == SVt_RV)
SvRV_set(dstr, NULL);
else
- SvPV_set(dstr, 0);
+ SvPV_set(dstr, NULL);
}
}
SV *dstr;
if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
- return Nullsv;
+ return NULL;
/* look for it in the table first */
dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
if (dstr)
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);
break;
case SVt_PVHV:
{
- HEK *hvname = 0;
+ HEK *hvname = NULL;
if (HvARRAY((HV*)sstr)) {
STRLEN i = 0;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
(bool)!!HvSHAREKEYS(sstr), param) : 0;
+ daux->xhv_backreferences = saux->xhv_backreferences
+ ? (AV*) SvREFCNT_inc(
+ sv_dup((SV*)saux->
+ xhv_backreferences,
+ param))
+ : 0;
}
}
else {
PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
}
else {
- PL_linestr = NEWSV(65,79);
+ PL_linestr = newSV(79);
sv_upgrade(PL_linestr,SVt_PVIV);
sv_setpvn(PL_linestr,"",0);
PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
else {
init_stacks();
ENTER; /* perl_destruct() wants to LEAVE; */
+
+ /* although we're not duplicating the tmps stack, we should still
+ * add entries for any SVs on the tmps stack that got cloned by a
+ * non-refcount means (eg a temp in @_); otherwise they will be
+ * orphaned
+ */
+ for (i = 0; i<= proto_perl->Ttmps_ix; i++) {
+ SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
+ proto_perl->Ttmps_stack[i]);
+ if (nsv && !SvREFCNT(nsv)) {
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc(nsv);
+ }
+ }
}
PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
STATIC I32
S_find_array_subscript(pTHX_ AV *av, SV* val)
{
+ dVAR;
SV** svp;
I32 i;
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
- SV * const sv = NEWSV(0,0);
+ SV * const sv = newSV(0);
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
}
else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
- sv_insert(name, 0, 0, "within ", 7);
+ Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
return name;
}
case OP_SCHOMP:
case OP_CHOMP:
if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
- return sv_2mortal(newSVpvn("${$/}", 5));
+ return sv_2mortal(newSVpvs("${$/}"));
/* FALL THROUGH */
default:
void
Perl_report_uninit(pTHX_ SV* uninit_sv)
{
+ dVAR;
if (PL_op) {
SV* varname = Nullsv;
if (uninit_sv) {