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) {
sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
- PL_nice_chunk = Nullch;
+ PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
}
else {
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);
=cut
*/
-#define free_arena(name) \
- STMT_START { \
- S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
- PL_ ## name ## _arenaroot = 0; \
- PL_ ## name ## _root = 0; \
- } STMT_END
-
void
Perl_sv_free_arenas(pTHX)
{
+ dVAR;
SV* sva;
SV* svanext;
int i;
Safefree(sva);
}
- for (i=0; i<SVt_LAST; i++) {
- S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
- PL_body_arenaroots[i] = 0;
+ S_free_arena(aTHX_ (void**) PL_body_arenas);
+
+ for (i=0; i<SVt_LAST; i++)
PL_body_roots[i] = 0;
- }
Safefree(PL_nice_chunk);
- PL_nice_chunk = Nullch;
+ PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
PL_sv_arenaroot = 0;
PL_sv_root = 0;
STATIC void *
S_more_bodies (pTHX_ size_t size, svtype sv_type)
{
- void ** const arena_root = &PL_body_arenaroots[sv_type];
- void ** const root = &PL_body_roots[sv_type];
+ dVAR;
+ void ** const root = &PL_body_roots[sv_type];
char *start;
const char *end;
const size_t count = PERL_ARENA_SIZE / size;
Newx(start, count*size, char);
- *((void **) start) = *arena_root;
- *arena_root = (void *)start;
+ *((void **) start) = PL_body_arenas;
+ PL_body_arenas = (void *)start;
end = start + (count-1) * size;
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 stores as all bits 0 then Zero() already creates a
- * correct 0.0 for us. */
- if (old_type_details->zero_nv)
+ * 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;
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
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, NULL, 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) = NULL;
+ 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) : NULL);
+ }
+ 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 = 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);
+ 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);
- 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;
- if (sflags & SVf_IVisUV)
- SvIsUV_on(dstr);
- SvIV_set(dstr, SvIVX(sstr));
- }
- if (SvAMAGIC(sstr)) {
- SvAMAGIC_on(dstr);
- }
+ SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC);
+ assert(!(sflags & SVp_NOK));
+ assert(!(sflags & SVp_IOK));
+ assert(!(sflags & SVf_NOK));
+ assert(!(sflags & SVf_IOK));
}
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);
{
if (len) { /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
- SV * const current = SV_COW_NEXT_SV(after);
+ SV *current = SV_COW_NEXT_SV(after);
if (current == sv) {
/* The SV we point to points back to us (there were only two of us
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. */
const STRLEN len = SvCUR(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
- SvPV_set(sv, Nullch);
+ SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
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
void
Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
+ dVAR;
AV *av;
if (SvTYPE(tsv) == SVt_PVHV) {
STATIC void
S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
{
+ dVAR;
AV *av = NULL;
SV **svp;
I32 i;
*/
svp[i] = svp[fill];
}
- svp[fill] = Nullsv;
+ svp[fill] = NULL;
AvFILLp(av) = fill - 1;
}
}
(UV)SvFLAGS(referrer));
}
- *svp = Nullsv;
+ *svp = NULL;
}
svp++;
}
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) {
I32
Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
const char *pv1;
STRLEN cur1;
const char *pv2;
STRLEN cur2;
I32 eq = 0;
- char *tpv = Nullch;
- SV* svrecode = Nullsv;
+ char *tpv = NULL;
+ SV* svrecode = NULL;
if (!sv1) {
pv1 = "";
I32
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
+ dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
- char *tpv = Nullch;
+ char *tpv = NULL;
I32 cmp;
- SV *svrecode = Nullsv;
+ SV *svrecode = NULL;
if (!sv1) {
pv1 = "";
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);
}
return_string_or_null:
- return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
+ return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
}
/*
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 (SvTYPE(old) == SVTYPEMASK) {
if (ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
- return Nullsv;
+ return NULL;
}
new_SV(sv);
/* SV_GMAGIC is the default for sv_setv()
SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
- if (SvPVX_const(sv) != Nullch)
+ if (SvPVX_const(sv) != NULL)
*SvPVX(sv) = '\0';
SvTAINT(sv);
}
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
dVAR;
- GV *gv = Nullgv;
- CV *cv = Nullcv;
+ GV *gv = NULL;
+ CV *cv = NULL;
if (!sv)
- return *st = NULL, *gvp = Nullgv, Nullcv;
+ return *st = NULL, *gvp = NULL, NULL;
switch (SvTYPE(sv)) {
case SVt_PVCV:
*st = CvSTASH(sv);
- *gvp = Nullgv;
+ *gvp = NULL;
return (CV*)sv;
case SVt_PVHV:
case SVt_PVAV:
*st = NULL;
- *gvp = Nullgv;
- return Nullcv;
+ *gvp = NULL;
+ return NULL;
case SVt_PVGV:
gv = (GV*)sv;
*gvp = gv;
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVCV) {
cv = (CV*)sv;
- *gvp = Nullgv;
+ *gvp = NULL;
*st = CvSTASH(cv);
return cv;
}
*gvp = gv;
if (!gv) {
*st = NULL;
- return Nullcv;
+ return NULL;
}
/* Some flags to gv_fetchsv mean don't really create the GV */
if (SvTYPE(gv) != SVt_PVGV) {
if (lref && !GvCVu(gv)) {
SV *tmpsv;
ENTER;
- tmpsv = NEWSV(704,0);
- gv_efullname3(tmpsv, gv, Nullch);
+ tmpsv = newSV(0);
+ gv_efullname3(tmpsv, gv, NULL);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
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);
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
into the SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
Do not use with other Perl types such as HV, AV, SV, CV, because those
SV*
Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
{
+ dVAR;
if (!pv) {
sv_setsv(rv, &PL_sv_undef);
SvSETMAGIC(rv);
Copies an integer into a new SV, optionally blessing the SV. The C<rv>
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
=cut
Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
=cut
Copies a double into a new SV, optionally blessing the SV. The C<rv>
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
-blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
=cut
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to the new SV. The C<classname>
argument indicates the package for the blessing. Set C<classname> to
-C<Nullch> to avoid the blessing. The new SV will have a reference count
+C<NULL> to avoid the blessing. The new SV will have a reference count
of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
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':
*len = endbuf - p;
return p;
}
- return Nullch;
+ return NULL;
}
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;
STRLEN origlen;
I32 svix = 0;
static const char nullstr[] = "(null)";
- SV *argsv = Nullsv;
+ SV *argsv = NULL;
bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
- SV *nsv = Nullsv;
+ SV *nsv = NULL;
/* Times 4: a decimal digit takes more than 3 binary digits.
* NV_DIG: mantissa takes than many decimal digits.
* Plus 32: Playing safe. */
U8 utf8buf[UTF8_MAXBYTES+1];
STRLEN esignlen = 0;
- const char *eptr = Nullch;
+ const char *eptr = NULL;
STRLEN elen = 0;
- SV *vecsv = Nullsv;
+ SV *vecsv = NULL;
const U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
char c = 0;
*/
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
if (RX_MATCH_COPIED(ret))
ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
else
- ret->subbeg = Nullch;
+ ret->subbeg = NULL;
#ifdef PERL_OLD_COPY_ON_WRITE
- ret->saved_copy = Nullsv;
+ ret->saved_copy = NULL;
#endif
ptr_table_store(PL_ptr_table, r, ret);
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);
}
}
else {
- SvPV_set(dstr, Nullch);
+ SvPV_set(dstr, NULL);
AvALLOC((AV*)dstr) = (SV**)NULL;
}
break;
}
}
else {
- SvPV_set(dstr, Nullch);
+ SvPV_set(dstr, NULL);
}
/* Record stashes for possible cloning in Perl_clone(). */
if(hvname)
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
- Nullgv : gv_dup(CvGV(dstr), param) ;
+ NULL : gv_dup(CvGV(dstr), param) ;
if (!(param->flags & CLONEf_COPY_STACKS)) {
CvDEPTH(dstr) = 0;
}
param->flags = flags;
param->proto_perl = proto_perl;
- Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
+ PL_body_arenas = NULL;
Zero(&PL_body_roots, 1, PL_body_roots);
PL_nice_chunk = NULL;
PL_nice_chunk_size = 0;
PL_sv_count = 0;
PL_sv_objcount = 0;
- PL_sv_root = Nullsv;
- PL_sv_arenaroot = Nullsv;
+ PL_sv_root = NULL;
+ PL_sv_arenaroot = NULL;
PL_debug = proto_perl->Idebug;
if (proto_perl->Iop_mask)
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
else
- PL_op_mask = Nullch;
+ PL_op_mask = NULL;
/* PL_asserting = proto_perl->Iasserting; */
/* current interpreter roots */
PL_lastfd = proto_perl->Ilastfd;
PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
PL_Argv = NULL;
- PL_Cmd = Nullch;
+ PL_Cmd = NULL;
PL_gensym = proto_perl->Igensym;
PL_preambled = proto_perl->Ipreambled;
PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
PL_laststatval = proto_perl->Ilaststatval;
PL_laststype = proto_perl->Ilaststype;
- PL_mess_sv = Nullsv;
+ PL_mess_sv = NULL;
PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
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);
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
PL_uudmap['M'] = 0; /* reinits on demand */
- PL_bitcount = Nullch; /* reinits on demand */
+ PL_bitcount = NULL; /* reinits on demand */
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
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 */
PL_op = proto_perl->Top;
- PL_Sv = Nullsv;
+ PL_Sv = NULL;
PL_Xpv = (XPV*)NULL;
PL_na = proto_perl->Tna;
PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
- PL_efloatbuf = Nullch; /* reinits on demand */
+ PL_efloatbuf = NULL; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
/* regex stuff */
PL_screamfirst = NULL;
PL_screamnext = NULL;
PL_maxscream = -1; /* reinits on demand */
- PL_lastscream = Nullsv;
+ PL_lastscream = NULL;
PL_watchaddr = NULL;
- PL_watchok = Nullch;
+ PL_watchok = NULL;
PL_regdummy = proto_perl->Tregdummy;
- PL_regprecomp = Nullch;
+ PL_regprecomp = NULL;
PL_regnpar = 0;
PL_regsize = 0;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
- PL_reginput = Nullch;
- PL_regbol = Nullch;
- PL_regeol = Nullch;
+ PL_reginput = NULL;
+ PL_regbol = NULL;
+ PL_regeol = NULL;
PL_regstartp = (I32*)NULL;
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
PL_reglastcloseparen = (U32*)NULL;
- PL_regtill = Nullch;
+ PL_regtill = NULL;
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
PL_regdata = (struct reg_data*)NULL;
- PL_bostr = Nullch;
+ PL_bostr = NULL;
PL_reg_flags = 0;
PL_reg_eval_set = 0;
PL_regnarrate = 0;
PL_regcc = (CURCUR*)NULL;
PL_reg_call_cc = (struct re_cc_state*)NULL;
PL_reg_re = (regexp*)NULL;
- PL_reg_ganch = Nullch;
- PL_reg_sv = Nullsv;
+ PL_reg_ganch = NULL;
+ PL_reg_sv = NULL;
PL_reg_match_utf8 = FALSE;
PL_reg_magic = (MAGIC*)NULL;
PL_reg_oldpos = 0;
PL_reg_oldcurpm = (PMOP*)NULL;
PL_reg_curpm = (PMOP*)NULL;
- PL_reg_oldsaved = Nullch;
+ PL_reg_oldsaved = NULL;
PL_reg_oldsavedlen = 0;
#ifdef PERL_OLD_COPY_ON_WRITE
- PL_nrs = Nullsv;
+ PL_nrs = NULL;
#endif
PL_reg_maxiter = 0;
PL_reg_leftiter = 0;
- PL_reg_poscache = Nullch;
+ PL_reg_poscache = NULL;
PL_reg_poscache_size= 0;
/* RE engine - function pointers */
if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
(HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
- return Nullsv;
+ return NULL;
array = HvARRAY(hv);
HeVAL(entry) == &PL_sv_placeholder)
continue;
if (!HeKEY(entry))
- return Nullsv;
+ return NULL;
if (HeKLEN(entry) == HEf_SVKEY)
return sv_mortalcopy(HeKEY_sv(entry));
return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
}
}
- return Nullsv;
+ return NULL;
}
/* Look for an entry in the array whose value has the same SV as val;
STATIC I32
S_find_array_subscript(pTHX_ AV *av, SV* val)
{
+ dVAR;
SV** svp;
I32 i;
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
AV *av;
if (!cv || !CvPADLIST(cv))
- return Nullsv;
+ return NULL;
av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
sv = *av_fetch(av, targ, FALSE);
/* SvLEN in a pad name is not to be trusted */
}
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;
}
if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
uninit_sv == &PL_sv_placeholder)))
- return Nullsv;
+ return NULL;
switch (obase->op_type) {
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);
I32 index = 0;
- SV *keysv = Nullsv;
+ SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
if (pad) { /* @lex, %lex */
sv = PAD_SVl(obase->op_targ);
- gv = Nullgv;
+ gv = NULL;
}
else {
if (cUNOPx(obase)->op_first->op_type == OP_GV) {
case OP_PADSV:
if (match && PAD_SVl(obase->op_targ) != uninit_sv)
break;
- return varname(Nullgv, '$', obase->op_targ,
- Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ return varname(NULL, '$', obase->op_targ,
+ NULL, 0, FUV_SUBSCRIPT_NONE);
case OP_GVSV:
gv = cGVOPx_gv(obase);
if (!gv || (match && GvSV(gv) != uninit_sv))
break;
- return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
case OP_AELEMFAST:
if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
if (!svp || *svp != uninit_sv)
break;
}
- return varname(Nullgv, '$', obase->op_targ,
- Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ return varname(NULL, '$', obase->op_targ,
+ NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
}
else {
gv = cGVOPx_gv(obase);
break;
}
return varname(gv, '$', 0,
- Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
}
break;
/* $a[uninit_expr] or $h{uninit_expr} */
return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
- gv = Nullgv;
+ gv = NULL;
o = cBINOPx(obase)->op_first;
kid = cBINOPx(obase)->op_last;
/* get the av or hv, and optionally the gv */
- sv = Nullsv;
+ sv = NULL;
if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
sv = PAD_SV(o->op_targ);
}
return varname(gv, '%', o->op_targ,
cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
else
- return varname(gv, '@', o->op_targ, Nullsv,
+ return varname(gv, '@', o->op_targ, NULL,
SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
}
else {
const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
if (index >= 0)
return varname(gv, '@', o->op_targ,
- Nullsv, index, FUV_SUBSCRIPT_ARRAY);
+ NULL, index, FUV_SUBSCRIPT_ARRAY);
}
if (match)
break;
return varname(gv,
(o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
? '@' : '%',
- o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
+ o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
break;
if (match && GvSV(gv) != uninit_sv)
break;
return varname(gv, '$', 0,
- Nullsv, 0, FUV_SUBSCRIPT_NONE);
+ NULL, 0, FUV_SUBSCRIPT_NONE);
}
/* other possibilities not handled are:
* open $x; or open my $x; should return '${*$x}'
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:
}
break;
}
- return Nullsv;
+ return NULL;
}
void
Perl_report_uninit(pTHX_ SV* uninit_sv)
{
+ dVAR;
if (PL_op) {
- SV* varname = Nullsv;
+ SV* varname = NULL;
if (uninit_sv) {
varname = find_uninit_var(PL_op, uninit_sv,0);
if (varname)
https://perl5.git.perl.org / perl5.git / blobdiff