X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=029de83ca32da15e0172fcd00d1ab267fb38cd82;hb=37c25af0ec94b55a9d5be380e5f1703e0afca56b;hp=65023927c504d4178af9c9decfe35403bde48906;hpb=c36d06f35d131cbc95ff19fae4a77cfabece4f82;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 6502392..029de83 100644 --- a/sv.c +++ b/sv.c @@ -2964,6 +2964,136 @@ S_glob_assign(pTHX_ SV *dstr, SV *sstr, const int dtype) 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) { @@ -3016,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; @@ -3037,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; @@ -3058,7 +3194,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvMULTI_on(dstr); return; } - return S_glob_assign(aTHX_ dstr, sstr, dtype); + S_glob_assign(aTHX_ dstr, sstr, dtype); + return; } break; case SVt_PVFM: @@ -3097,7 +3234,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVGV: if (dtype <= SVt_PVGV) { - return S_glob_assign(aTHX_ dstr, sstr, dtype); + S_glob_assign(aTHX_ dstr, sstr, dtype); + return; } /* FALL THROUGH */ @@ -3106,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) - return S_glob_assign(aTHX_ dstr, sstr, dtype); + if (stype == SVt_PVGV && dtype <= SVt_PVGV) { + S_glob_assign(aTHX_ dstr, sstr, dtype); + return; + } } } if (stype == SVt_PVLV) @@ -3121,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)) { @@ -3264,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; @@ -3405,57 +3406,39 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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))