X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e8f91c91cc7c3a4a35c08d16f350eabe4852cdf4..6af091cddde7717ea89d9dd2196f18d5f4431198:/gv.c?ds=sidebyside diff --git a/gv.c b/gv.c index bda30b1..1ef1155 100644 --- a/gv.c +++ b/gv.c @@ -21,7 +21,6 @@ /* =head1 GV Functions - A GV is a structure which corresponds to to a Perl typeglob, ie *foo. It is a structure that holds a pointer to a scalar, an array, a hash etc, corresponding to $foo, @foo, %foo. @@ -353,6 +352,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", sv_reftype(has_constant, 0)); + default: NOOP; } SvRV_set(gv, NULL); @@ -1452,7 +1452,7 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, tmpbuf[(*len)++] = ':'; key = tmpbuf; } - gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -(*len) : *len, add); + gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add); *gv = gvp ? *gvp : NULL; if (*gv && *gv != (const GV *)&PL_sv_undef) { if (SvTYPE(*gv) != SVt_PVGV) @@ -1583,7 +1583,7 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, !(len == 1 && sv_type == SVt_PV && (*name == 'a' || *name == 'b')) ) { - GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -len : len,0); + GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0); if (!gvp || *gvp == (const GV *)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { @@ -1693,7 +1693,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case 'b': if (len == 1 && sv_type == SVt_PV) GvMULTI_on(gv); - /* FALL THROUGH */ + /* FALLTHROUGH */ default: goto try_core; } @@ -1968,7 +1968,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '\023': /* $^S */ ro_magicalize: SvREADONLY_on(GvSVn(gv)); - /* FALL THROUGH */ + /* FALLTHROUGH */ case '0': /* $0 */ case '^': /* $^ */ case '~': /* $~ */ @@ -2119,7 +2119,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } /* By this point we should have a stash and a name */ - gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add); + gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); if (!gvp || *gvp == (const GV *)&PL_sv_undef) { if (addmg) gv = (GV *)newSV(0); else return NULL; @@ -2253,6 +2253,11 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } + +/* recursively scan a stash and any nested stashes looking for entries + * that need the "only used once" warning raised + */ + void Perl_gv_check(pTHX_ HV *stash) { @@ -2263,18 +2268,23 @@ Perl_gv_check(pTHX_ HV *stash) if (!HvARRAY(stash)) return; + + assert(SvOOK(stash)); + for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; - /* SvIsCOW is unused on HVs, so we can use it to mark stashes we - are currently searching through recursively. */ - SvIsCOW_on(stash); + /* mark stash is being scanned, to avoid recursing */ + HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { GV *gv; HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) { - if (hv != PL_defstash && hv != stash && !SvIsCOW(hv)) + if (hv != PL_defstash && hv != stash + && !(SvOOK(hv) + && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) + ) gv_check(hv); /* nested package */ } else if ( *HeKEY(entry) != '_' @@ -2298,7 +2308,7 @@ Perl_gv_check(pTHX_ HV *stash) HEKfARG(GvNAME_HEK(gv))); } } - SvIsCOW_off(stash); + HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; } } @@ -2389,7 +2399,7 @@ Perl_gp_free(pTHX_ GV *gv) Somehow gp->gp_hv can end up pointing at freed garbage. */ if (hv && SvTYPE(hv) == SVt_PVHV) { const HEK *hvname_hek = HvNAME_HEK(hv); - DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek)); + DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek))); if (PL_stashcache && hvname_hek) (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); SvREFCNT_dec(hv); @@ -2481,6 +2491,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { int filled = 0; int i; + bool deref_seen = 0; + /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ @@ -2511,6 +2523,10 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) filled = 1; } + assert(SvOOK(stash)); + /* initially assume the worst */ + HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; + for (i = 1; i < NofAMmeth; i++) { const char * const cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ @@ -2577,7 +2593,26 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) filled = 1; } amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); + + if (gv) { + switch (i) { + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + case nomethod_amg: + deref_seen = 1; + break; + } + } } + if (!deref_seen) + /* none of @{} etc overloaded; we can do $obj->[N] quicker. + * NB - aux var invalid here, HvARRAY() could have been + * reallocated since it was assigned to */ + HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF; + if (filled) { AMT_AMAGIC_on(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, @@ -2747,11 +2782,19 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { SV * Perl_amagic_deref_call(pTHX_ SV *ref, int method) { SV *tmpsv = NULL; + HV *stash; PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; - while (SvAMAGIC(ref) && - (tmpsv = amagic_call(ref, &PL_sv_undef, method, + if (!SvAMAGIC(ref)) + return ref; + /* return quickly if none of the deref ops are overloaded */ + stash = SvSTASH(SvRV(ref)); + assert(SvOOK(stash)); + if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF) + return ref; + + while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, AMGf_noright | AMGf_unary))) { if (!SvROK(tmpsv)) Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); @@ -2760,6 +2803,8 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return tmpsv; } ref = tmpsv; + if (!SvAMAGIC(ref)) + break; } return tmpsv ? tmpsv : ref; } @@ -2924,7 +2969,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case regexp_amg: /* FAIL safe */ return NULL; /* Delegate operation to standard mechanisms. */ - break; + case to_sv_amg: case to_av_amg: case to_hv_amg: @@ -2932,7 +2977,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case to_cv_amg: /* FAIL safe */ return left; /* Delegate operation to standard mechanisms. */ - break; + default: goto not_found; } @@ -2999,7 +3044,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case to_cv_amg: /* FAIL safe */ return left; /* Delegate operation to standard mechanisms. */ - break; } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1;