X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ffdb8bcde21504a3efe208b4d47bea445e7e23fd..f041cf0f9c6469c41de8b73d5f7b426710c3ff8b:/gv.c diff --git a/gv.c b/gv.c index 9da6c1a..2befa71 100644 --- a/gv.c +++ b/gv.c @@ -318,7 +318,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; char * const proto = (doproto && SvPOK(gv)) - ? (SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0), SvPVX(gv)) + ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) : NULL; const STRLEN protolen = proto ? SvCUR(gv) : 0; const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; @@ -482,6 +482,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, gv = (GV *)newSV(0); gv_init(gv, stash, name, len, TRUE); } + GvMULTI_on(gv); if (ampable) { ENTER; oldcurcop = PL_curcop; @@ -516,15 +517,16 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { CvLVALUE_on(cv); - newATTRSUB(oldsavestack_ix, - newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(gv)), + newATTRSUB_flags( + oldsavestack_ix, (OP *)gv, NULL,NULL, coresub_op( opnum ? newSVuv((UV)opnum) : newSVpvn(name,len), code, opnum - ) + ), + 1 ); assert(GvCV(gv) == cv); if (opnum != OP_VEC && opnum != OP_SUBSTR) @@ -909,8 +911,10 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags) sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); #ifdef USE_ITHREADS av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop), - strlen(CopSTASHPV(PL_curcop)), - CopSTASH_flags(PL_curcop) + CopSTASH_len(PL_curcop) < 0 + ? -CopSTASH_len(PL_curcop) + : CopSTASH_len(PL_curcop), + SVf_UTF8*(CopSTASH_len(PL_curcop) < 0) )); #else av_push(superisa, newSVhek(CopSTASH(PL_curcop) @@ -1399,18 +1403,6 @@ S_gv_magicalize_isa(pTHX_ GV *gv) NULL, 0); } -STATIC void -S_gv_magicalize_overload(pTHX_ GV *gv) -{ - HV* hv; - - PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD; - - hv = GvHVn(gv); - GvMULTI_on(gv); - hv_magic(hv, NULL, PERL_MAGIC_overload); -} - GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) @@ -1693,7 +1685,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* set up magic where warranted */ if (stash != PL_defstash) { /* not the main stash */ - /* We only have to check for four names here: EXPORT, ISA, OVERLOAD + /* We only have to check for three names here: EXPORT, ISA and VERSION. All the others apply only to the main stash or to CORE (which is checked right after this). */ if (len > 2) { @@ -1707,10 +1699,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "SA")) gv_magicalize_isa(gv); break; - case 'O': - if (strEQ(name2, "VERLOAD")) - gv_magicalize_overload(gv); - break; case 'V': if (strEQ(name2, "ERSION")) GvMULTI_on(gv); @@ -1758,11 +1746,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, gv_magicalize_isa(gv); } break; - case 'O': - if (strEQ(name2, "VERLOAD")) { - gv_magicalize_overload(gv); - } - break; case 'S': if (strEQ(name2, "IG")) { HV *hv; @@ -1913,7 +1896,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, SvREADONLY_on(av); if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + { + if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); + addmg = 0; require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); + } break; } @@ -2275,24 +2262,31 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) int filled = 0, have_ovl = 0; int i, lim = 1; - /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ + /* The first key in PL_AMG_names is the overloadedness indicator, which + allows us to skip overloading entries for non-overloaded classes. */ /* Try to find via inheritance. */ GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0); - SV * const sv = gv ? GvSV(gv) : NULL; CV* cv; if (!gv) lim = DESTROY_amg; /* Skip overloading entries. */ -#ifdef PERL_DONT_CREATE_GVSV - else if (!sv) { + + else { + + /* The "fallback" key is special-cased here, being absent from the + list in PL_AMG_names. */ + + SV *sv; + gv = gv_fetchmeth_pvn(stash, "(fallback", 9, -1, 0); + + if (!gv || !(sv = GvSV(gv))) NOOP; /* Equivalent to !SvTRUE and !SvOK */ - } -#endif - else if (SvTRUE(sv)) + else if (SvTRUE(sv)) amt.fallback=AMGfallYES; - else if (SvOK(sv)) + else if (SvOK(sv)) amt.fallback=AMGfallNEVER; + } for (i = 1; i < lim; i++) amt.table[i] = NULL; @@ -2568,6 +2562,31 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return tmpsv ? tmpsv : ref; } +bool +Perl_amagic_is_enabled(pTHX_ int method) +{ + SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); + + assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); + + if ( !lex_mask || !SvOK(lex_mask) ) + /* overloading lexically disabled */ + return FALSE; + else if ( lex_mask && SvPOK(lex_mask) ) { + /* we have an entry in the hints hash, check if method has been + * masked by overloading.pm */ + STRLEN len; + const int offset = method / 8; + const int bit = method % 8; + char *pv = SvPV(lex_mask, len); + + /* Bit set, so this overloading operator is disabled */ + if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) + return FALSE; + } + return TRUE; +} + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { @@ -2589,27 +2608,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PERL_ARGS_ASSERT_AMAGIC_CALL; if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { - SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); - - if ( !lex_mask || !SvOK(lex_mask) ) - /* overloading lexically disabled */ - return NULL; - else if ( lex_mask && SvPOK(lex_mask) ) { - /* we have an entry in the hints hash, check if method has been - * masked by overloading.pm */ - STRLEN len; - const int offset = method / 8; - const int bit = method % 8; - char *pv = SvPV(lex_mask, len); - - /* Bit set, so this overloading operator is disabled */ - if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) - return NULL; - } + if (!amagic_is_enabled(method)) return NULL; } if (!(AMGf_noleft & flags) && SvAMAGIC(left) - && (stash = SvSTASH(SvRV(left))) + && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table @@ -2674,12 +2677,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) */ SV* const newref = newSVsv(tmpRef); SvOBJECT_on(newref); - /* As a bit of a source compatibility hack, SvAMAGIC() and - friends dereference an RV, to behave the same was as when - overloading was stored on the reference, not the referant. - Hence we can't use SvAMAGIC_on() - */ - SvFLAGS(newref) |= SVf_AMAGIC; + /* No need to do SvAMAGIC_on here, as SvAMAGIC macros + delegate to the stash. */ SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); return newref; } @@ -2736,14 +2735,21 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) - && (stash = SvSTASH(SvRV(right))) + && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : NULL)) - && (cv = cvp[off=method])) { /* Method for right - * argument found */ - lr=1; + && ((cv = cvp[off=method+assignshift]) + || (assign && amtp->fallback > AMGfallNEVER && /* fallback to + * usual method */ + ( +#ifdef DEBUGGING + fl = 1, +#endif + cv = cvp[off=method])))) { /* Method for right + * argument found */ + lr=1; } else if (((cvp && amtp->fallback > AMGfallNEVER) || (ocvp && oamtp->fallback > AMGfallNEVER)) && !(flags & AMGf_unary)) {