X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=029de83ca32da15e0172fcd00d1ab267fb38cd82;hb=37c25af0ec94b55a9d5be380e5f1703e0afca56b;hp=e6690c11d456b61b4a4e0d1d2b993f62bff8e4f6;hpb=89529cee496f815eec2d49f2510449af5063ddd8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index e6690c1..029de83 100644 --- a/sv.c +++ b/sv.c @@ -177,6 +177,7 @@ Public API: void Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) { + dVAR; void *new_chunk; U32 new_chunk_size; LOCK_SV_MUTEX; @@ -236,6 +237,7 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) STATIC SV* S_more_sv(pTHX) { + dVAR; SV* sv; if (PL_nice_chunk) { @@ -314,6 +316,7 @@ S_new_SV(pTHX) STATIC void S_del_sv(pTHX_ SV *p) { + dVAR; if (DEBUG_D_TEST) { SV* sva; bool ok = 0; @@ -357,6 +360,7 @@ and split it into a list of free SVs. void Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) { + dVAR; SV* const sva = (SV*)ptr; register SV* sv; register SV* svend; @@ -394,6 +398,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) STATIC I32 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask) { + dVAR; SV* sva; I32 visited = 0; @@ -448,6 +453,7 @@ Perl_sv_report_used(pTHX) static void do_clean_objs(pTHX_ SV *ref) { + dVAR; if (SvROK(ref)) { SV * const target = SvRV(ref); if (SvOBJECT(target)) { @@ -473,6 +479,7 @@ do_clean_objs(pTHX_ SV *ref) static void do_clean_named_objs(pTHX_ SV *sv) { + dVAR; if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { if (( #ifdef PERL_DONT_CREATE_GVSV @@ -503,6 +510,7 @@ Attempt to destroy all objects not yet freed void Perl_sv_clean_objs(pTHX) { + dVAR; PL_in_clean_objs = TRUE; visit(do_clean_objs, SVf_ROK, SVf_ROK); #ifndef DISABLE_DESTRUCTOR_KLUDGE @@ -517,6 +525,7 @@ Perl_sv_clean_objs(pTHX) 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) { @@ -539,6 +548,7 @@ SVs which are in complex self-referential hierarchies. I32 Perl_sv_clean_all(pTHX) { + dVAR; I32 cleaned; PL_in_clean_all = TRUE; cleaned = visit(do_clean_all, 0,0); @@ -573,6 +583,7 @@ heads and bodies within the arenas must already have been freed. void Perl_sv_free_arenas(pTHX) { + dVAR; SV* sva; SV* svanext; int i; @@ -640,6 +651,7 @@ Perl_sv_free_arenas(pTHX) 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; @@ -693,6 +705,7 @@ S_more_bodies (pTHX_ size_t size, svtype sv_type) STATIC void * S_new_body(pTHX_ size_t size, svtype sv_type) { + dVAR; void *xpv; new_body_inline(xpv, size, sv_type); return xpv; @@ -930,6 +943,7 @@ You generally want to use the C macro wrapper. See also C. void Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) { + dVAR; void* old_body; void* new_body; const U32 old_type = SvTYPE(sv); @@ -1076,14 +1090,14 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) /* 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; @@ -1135,10 +1149,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) 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) { @@ -1255,6 +1270,7 @@ Does not handle 'set' magic. See also C. void Perl_sv_setiv(pTHX_ register SV *sv, IV i) { + dVAR; SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -1355,6 +1371,7 @@ Does not handle 'set' magic. See also C. void Perl_sv_setnv(pTHX_ register SV *sv, NV num) { + dVAR; SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -1403,6 +1420,7 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) STATIC void S_not_a_number(pTHX_ SV *sv) { + dVAR; SV *dsv; char tmpbuf[64]; const char *pv; @@ -1584,6 +1602,7 @@ Perl_looks_like_number(pTHX_ SV *sv) 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); @@ -1630,6 +1649,7 @@ S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) 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 @@ -1881,6 +1901,7 @@ Normally used via the C and C macros. IV Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) { + dVAR; if (!sv) return 0; if (SvGMAGICAL(sv)) { @@ -1960,6 +1981,7 @@ Normally used via the C and C macros. UV Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) { + dVAR; if (!sv) return 0; if (SvGMAGICAL(sv)) { @@ -2034,6 +2056,7 @@ macros. NV Perl_sv_2nv(pTHX_ register SV *sv) { + dVAR; if (!sv) return 0.0; if (SvGMAGICAL(sv)) { @@ -2263,6 +2286,7 @@ S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) 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) { @@ -2352,6 +2376,7 @@ usually end up here too. char * Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) { + dVAR; register char *s; if (!sv) { @@ -2638,6 +2663,7 @@ sv_true() or its macro equivalent. bool Perl_sv_2bool(pTHX_ register SV *sv) { + dVAR; SvGETMAGIC(sv); if (!SvOK(sv)) @@ -2701,6 +2727,7 @@ use the Encode extension for that. STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) { + dVAR; if (sv == &PL_sv_undef) return 0; if (!SvPOK(sv)) { @@ -2770,6 +2797,7 @@ use the Encode extension for that. bool Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) { + dVAR; if (SvPOKp(sv) && SvUTF8(sv)) { if (SvCUR(sv)) { U8 *s; @@ -2897,9 +2925,179 @@ copy-ish functions and macros use this underneath. =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; @@ -2948,8 +3146,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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; @@ -2969,8 +3170,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } 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; @@ -2990,7 +3194,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvMULTI_on(dstr); return; } - goto glob_assign; + S_glob_assign(aTHX_ dstr, sstr, dtype); + return; } break; case SVt_PVFM: @@ -3029,40 +3234,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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 */ @@ -3072,8 +3244,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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) @@ -3087,139 +3261,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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)) { @@ -3230,25 +3272,18 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } (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; @@ -3365,63 +3400,45 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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)) @@ -3531,6 +3548,7 @@ undefined. Does not handle 'set' magic. See C. 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); @@ -3581,6 +3599,7 @@ handle 'set' magic. See C. void Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) { + dVAR; register STRLEN len; SV_CHECK_THINKFIRST_COW_DROP(sv); @@ -3630,6 +3649,7 @@ See C. 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); @@ -3731,6 +3751,7 @@ with flags set to 0. 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. */ @@ -3748,7 +3769,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) 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. */ @@ -3860,6 +3881,7 @@ in terms of this function. 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); @@ -3894,6 +3916,7 @@ and C are implemented in terms of this function. 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); @@ -3942,6 +3965,7 @@ valid UTF-8. Handles 'get' magic, but not 'set' magic. See C. void Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) { + dVAR; register STRLEN len; STRLEN tlen; char *junk; @@ -3977,9 +4001,16 @@ Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) /* =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 -macro. +Creates a new SV. A non-zero C 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, a debug aid which allowed callers to identify themselves. +This aid has been superseded by a new build option, PERL_MEM_LOG (see +L). The older API is still there for use in XS +modules supporting older perls. =cut */ @@ -3987,6 +4018,7 @@ macro. SV * Perl_newSV(pTHX_ STRLEN len) { + dVAR; register SV *sv; new_SV(sv); @@ -4016,9 +4048,10 @@ to contain an C and is stored as-is with its REFCNT incremented. =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) { @@ -4103,7 +4136,8 @@ to add more than one instance of the same 'how'. 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 @@ -4353,6 +4387,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv) void Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) { + dVAR; AV *av; if (SvTYPE(tsv) == SVt_PVHV) { @@ -4406,6 +4441,7 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) STATIC void S_sv_del_backref(pTHX_ SV *tsv, SV *sv) { + dVAR; AV *av = NULL; SV **svp; I32 i; @@ -4505,6 +4541,7 @@ the Perl substr() function. 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; @@ -4602,6 +4639,7 @@ time you'll want to use C or one of its many macro front-ends. 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) { @@ -5388,6 +5426,7 @@ coerce its args to strings if necessary. I32 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) { + dVAR; const char *pv1; STRLEN cur1; const char *pv2; @@ -5483,6 +5522,7 @@ coerce its args to strings if necessary. See also C. I32 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { + dVAR; STRLEN cur1, cur2; const char *pv1, *pv2; char *tpv = Nullch; @@ -5566,6 +5606,7 @@ if necessary. See also C. See also C. I32 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) { + dVAR; #ifdef USE_LOCALE_COLLATE char *pv1, *pv2; @@ -5630,6 +5671,7 @@ settings. char * Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) { + dVAR; MAGIC *mg; mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; @@ -5686,6 +5728,7 @@ appending to the currently-stored string. char * Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) { + dVAR; const char *rsptr; STRLEN rslen; register STDCHAR rslast; @@ -5713,7 +5756,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) 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); @@ -6041,6 +6084,7 @@ if necessary. Handles 'get' magic. void Perl_sv_inc(pTHX_ register SV *sv) { + dVAR; register char *d; int flags; @@ -6197,6 +6241,7 @@ if necessary. Handles 'get' magic. void Perl_sv_dec(pTHX_ register SV *sv) { + dVAR; int flags; if (!sv) @@ -6313,6 +6358,7 @@ statement boundaries. See also C and C. SV * Perl_sv_mortalcopy(pTHX_ SV *oldstr) { + dVAR; register SV *sv; new_SV(sv); @@ -6337,6 +6383,7 @@ See also C and C. SV * Perl_sv_newmortal(pTHX) { + dVAR; register SV *sv; new_SV(sv); @@ -6385,6 +6432,7 @@ strlen(). For efficiency, consider using C instead. SV * Perl_newSVpv(pTHX_ const char *s, STRLEN len) { + dVAR; register SV *sv; new_SV(sv); @@ -6406,6 +6454,7 @@ C bytes long. If the C argument is NULL the new SV will be undefined. SV * Perl_newSVpvn(pTHX_ const char *s, STRLEN len) { + dVAR; register SV *sv; new_SV(sv); @@ -6427,6 +6476,7 @@ SV if the hek is NULL. SV * Perl_newSVhek(pTHX_ const HEK *hek) { + dVAR; if (!hek) { SV *sv; @@ -6485,6 +6535,7 @@ hash lookup will avoid string compare. SV * Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) { + dVAR; register SV *sv; bool is_utf8 = FALSE; if (len < 0) { @@ -6555,6 +6606,7 @@ Perl_newSVpvf(pTHX_ const char* pat, ...) 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*)); @@ -6573,6 +6625,7 @@ The reference count for the SV is set to 1. SV * Perl_newSVnv(pTHX_ NV n) { + dVAR; register SV *sv; new_SV(sv); @@ -6592,6 +6645,7 @@ SV is set to 1. SV * Perl_newSViv(pTHX_ IV i) { + dVAR; register SV *sv; new_SV(sv); @@ -6611,6 +6665,7 @@ The reference count for the SV is set to 1. SV * Perl_newSVuv(pTHX_ UV u) { + dVAR; register SV *sv; new_SV(sv); @@ -6630,6 +6685,7 @@ SV is B incremented. SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { + dVAR; register SV *sv; new_SV(sv); @@ -6647,6 +6703,7 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) SV * Perl_newRV(pTHX_ SV *tmpRef) { + dVAR; return newRV_noinc(SvREFCNT_inc(tmpRef)); } @@ -6662,6 +6719,7 @@ Creates a new SV which is an exact duplicate of the original SV. SV * Perl_newSVsv(pTHX_ register SV *old) { + dVAR; register SV *sv; if (!old) @@ -6888,7 +6946,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) 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 @@ -6964,7 +7022,7 @@ C and C 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); @@ -7162,6 +7220,7 @@ reference count is 1. SV* Perl_newSVrv(pTHX_ SV *rv, const char *classname) { + dVAR; SV *sv; new_SV(sv); @@ -7217,6 +7276,7 @@ Note that C copies the string while this copies the pointer. SV* Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) { + dVAR; if (!pv) { sv_setsv(rv, &PL_sv_undef); SvSETMAGIC(rv); @@ -7318,6 +7378,7 @@ of the SV is unaffected. SV* Perl_sv_bless(pTHX_ SV *sv, HV *stash) { + dVAR; SV *tmpRef; if (!SvROK(sv)) Perl_croak(aTHX_ "Can't bless non-reference value"); @@ -7357,6 +7418,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) STATIC void S_sv_unglob(pTHX_ SV *sv) { + dVAR; void *xpvmg; assert(SvTYPE(sv) == SVt_PVGV); @@ -7714,6 +7776,7 @@ Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STATIC I32 S_expect_number(pTHX_ char** pattern) { + dVAR; I32 var = 0; switch (**pattern) { case '1': case '2': case '3': @@ -7781,6 +7844,7 @@ Usually used via one of its frontends C and C. 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; @@ -8098,6 +8162,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV */ 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 @@ -8865,8 +8934,8 @@ ptr_table_* functions. #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 @@ -9298,7 +9367,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) if (SvTYPE(dstr) == SVt_RV) SvRV_set(dstr, NULL); else - SvPV_set(dstr, 0); + SvPV_set(dstr, NULL); } } @@ -9311,7 +9380,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) 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) @@ -10570,7 +10639,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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); @@ -10777,7 +10846,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * orphaned */ for (i = 0; i<= proto_perl->Ttmps_ix; i++) { - SV *nsv = (SV*)ptr_table_fetch(PL_ptr_table, + SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table, proto_perl->Ttmps_stack[i]); if (nsv && !SvREFCNT(nsv)) { EXTEND_MORTAL(1); @@ -11100,6 +11169,7 @@ S_find_hash_subscript(pTHX_ HV *hv, SV* val) STATIC I32 S_find_array_subscript(pTHX_ AV *av, SV* val) { + dVAR; SV** svp; I32 i; if (!av || SvMAGICAL(av) || !AvARRAY(av) || @@ -11164,7 +11234,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, } 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)); @@ -11506,6 +11576,7 @@ Print appropriate "Use of uninitialized variable" warning void Perl_report_uninit(pTHX_ SV* uninit_sv) { + dVAR; if (PL_op) { SV* varname = Nullsv; if (uninit_sv) {