diff options
| -rw-r--r-- | dump.c | 9 | ||||
| -rw-r--r-- | embed.fnc | 8 | ||||
| -rw-r--r-- | embed.h | 14 | ||||
| -rw-r--r-- | hv.c | 41 | ||||
| -rw-r--r-- | hv.h | 1 | ||||
| -rw-r--r-- | mg.c | 37 | ||||
| -rw-r--r-- | proto.h | 15 | ||||
| -rw-r--r-- | sv.c | 122 |
8 files changed, 193 insertions, 54 deletions
@@ -1439,6 +1439,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (hvname) Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname); } + if (SvOOK(sv)) { + AV *backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv); + if (backrefs) { + Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n", + PTR2UV(backrefs)); + do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest, + dumpops, pvlim); + } + } if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */ HE *he; HV * const hv = (HV*)sv; @@ -1303,6 +1303,10 @@ s |SV* |save_scalar_at |NN SV **sptr po |void |sv_add_backref |NN SV *tsv|NN SV *sv #endif +#if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +poM |int |sv_kill_backrefs |NN SV *sv|NN AV *av +#endif + #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) nsR |char * |uiv_2buf |NN char *buf|IV iv|UV uv|int is_uv|NN char **peob s |void |sv_unglob |NN SV* sv @@ -1499,6 +1503,10 @@ ApoR |HE** |hv_eiter_p |NN HV* hv Apo |void |hv_riter_set |NN HV* hv|I32 riter Apo |void |hv_eiter_set |NN HV* hv|NULLOK HE* eiter Ap |void |hv_name_set |NN HV* hv|NULLOK const char *name|I32 len|int flags +poM |AV** |hv_backreferences_p |NN HV* hv +#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +poM |void |hv_kill_backrefs |NN HV* hv +#endif Apd |void |hv_clear_placeholders |NN HV* hb ApoR |I32* |hv_placeholders_p |NN HV* hv ApoR |I32 |hv_placeholders_get |NN HV* hv @@ -1329,6 +1329,8 @@ #endif #if defined(PERL_IN_GV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) #endif +#if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#endif #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define uiv_2buf S_uiv_2buf @@ -1537,6 +1539,8 @@ #define save_set_svflags Perl_save_set_svflags #define hv_scalar Perl_hv_scalar #define hv_name_set Perl_hv_name_set +#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#endif #define hv_clear_placeholders Perl_hv_clear_placeholders #ifdef PERL_CORE #define magic_scalarpack Perl_magic_scalarpack @@ -3367,6 +3371,10 @@ #ifdef PERL_CORE #endif #endif +#if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#endif +#endif #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) #ifdef PERL_CORE #define uiv_2buf S_uiv_2buf @@ -3575,6 +3583,12 @@ #define save_set_svflags(a,b,c) Perl_save_set_svflags(aTHX_ a,b,c) #define hv_scalar(a) Perl_hv_scalar(aTHX_ a) #define hv_name_set(a,b,c,d) Perl_hv_name_set(aTHX_ a,b,c,d) +#ifdef PERL_CORE +#endif +#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +#ifdef PERL_CORE +#endif +#endif #define hv_clear_placeholders(a) Perl_hv_clear_placeholders(aTHX_ a) #ifdef PERL_CORE #define magic_scalarpack(a,b) Perl_magic_scalarpack(aTHX_ a,b) @@ -1658,6 +1658,21 @@ S_hfreeentries(pTHX_ HV *hv) iter = SvOOK(hv) ? HvAUX(hv) : 0; + /* If there are weak references to this HV, we need to avoid freeing them + up here. + */ + if (iter) { + if (iter->xhv_backreferences) { + /* So donate them to regular backref magic to keep them safe. The + sv_magic will increase the reference count of the AV, so we need + to drop it first. */ + SvREFCNT_dec(iter->xhv_backreferences); + sv_magic((SV*)hv, (SV*)iter->xhv_backreferences, + PERL_MAGIC_backref, NULL, 0); + iter->xhv_backreferences = 0; + } + } + riter = 0; max = HvMAX(hv); array = HvARRAY(hv); @@ -1726,6 +1741,7 @@ Perl_hv_undef(pTHX_ HV *hv) { register XPVHV* xhv; const char *name; + if (!hv) return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); @@ -1767,7 +1783,7 @@ S_hv_auxinit(pTHX_ HV *hv) { iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ iter->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ iter->xhv_name = 0; - + iter->xhv_backreferences = 0; return iter; } @@ -1892,6 +1908,29 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, I32 len, int flags) iter->xhv_name = name ? share_hek(name, len, hash) : 0; } +AV ** +Perl_hv_backreferences_p(pTHX_ HV *hv) { + struct xpvhv_aux *iter; + + iter = SvOOK(hv) ? HvAUX(hv) : S_hv_auxinit(aTHX_ hv); + return &(iter->xhv_backreferences); +} + +void +Perl_hv_kill_backrefs(pTHX_ HV *hv) { + AV *av; + + if (!SvOOK(hv)) + return; + + av = HvAUX(hv)->xhv_backreferences; + + if (av) { + HvAUX(hv)->xhv_backreferences = 0; + Perl_sv_kill_backrefs(aTHX_ (SV*) hv, av); + } +} + /* hv_iternext is implemented as a macro in hv.h @@ -38,6 +38,7 @@ struct shared_he { */ struct xpvhv_aux { HEK *xhv_name; /* name, if a symbol table */ + AV *xhv_backreferences; /* back references for weak references */ HE *xhv_eiter; /* current entry of iterator */ I32 xhv_riter; /* current root of iterator */ }; @@ -2043,42 +2043,7 @@ Perl_vivify_defelem(pTHX_ SV *sv) int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) { - AV *const av = (AV*)mg->mg_obj; - SV **svp = AvARRAY(av); - PERL_UNUSED_ARG(sv); - - /* Not sure why the av can get freed ahead of its sv, but somehow it does - in ext/B/t/bytecode.t test 15 (involving print <DATA>) */ - if (svp && !SvIS_FREED(av)) { - SV *const *const last = svp + AvFILLp(av); - - while (svp <= last) { - if (*svp) { - SV *const referrer = *svp; - if (SvWEAKREF(referrer)) { - /* XXX Should we check that it hasn't changed? */ - SvRV_set(referrer, 0); - SvOK_off(referrer); - SvWEAKREF_off(referrer); - } else if (SvTYPE(referrer) == SVt_PVGV || - SvTYPE(referrer) == SVt_PVLV) { - /* You lookin' at me? */ - assert(GvSTASH(referrer)); - assert(GvSTASH(referrer) == (HV*)sv); - GvSTASH(referrer) = 0; - } else { - Perl_croak(aTHX_ - "panic: magic_killbackrefs (flags=%"UVxf")", - (UV)SvFLAGS(referrer)); - } - - *svp = Nullsv; - } - svp++; - } - } - SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ - return 0; + return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj); } int @@ -3653,6 +3653,13 @@ PERL_CALLCONV void Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) #endif +#if defined(PERL_IN_HV_C) || defined(PERL_IN_MG_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +PERL_CALLCONV int Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); + +#endif + #if defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) STATIC char * S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) __attribute__warn_unused_result__ @@ -4077,6 +4084,14 @@ PERL_CALLCONV void Perl_hv_eiter_set(pTHX_ HV* hv, HE* eiter) PERL_CALLCONV void Perl_hv_name_set(pTHX_ HV* hv, const char *name, I32 len, int flags) __attribute__nonnull__(pTHX_1); +PERL_CALLCONV AV** Perl_hv_backreferences_p(pTHX_ HV* hv) + __attribute__nonnull__(pTHX_1); + +#if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_DECL_PROT) +PERL_CALLCONV void Perl_hv_kill_backrefs(pTHX_ HV* hv) + __attribute__nonnull__(pTHX_1); + +#endif PERL_CALLCONV void Perl_hv_clear_placeholders(pTHX_ HV* hb) __attribute__nonnull__(pTHX_1); @@ -4305,7 +4305,8 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) } if (!SvMAGIC(sv)) { SvMAGICAL_off(sv); - SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT; + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT; + SvMAGIC_set(sv, NULL); } return 0; @@ -4350,16 +4351,44 @@ void Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) { AV *av; - MAGIC *mg; - if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref))) - av = (AV*)mg->mg_obj; - else { - av = newAV(); - AvREAL_off(av); - sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); - /* av now has a refcnt of 2, which avoids it getting freed - * before us during global cleanup. The extra ref is removed - * by magic_killbackrefs() when tsv is being freed */ + + if (SvTYPE(tsv) == SVt_PVHV) { + AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv); + + av = *avp; + if (!av) { + /* There is no AV in the offical place - try a fixup. */ + MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref); + + if (mg) { + /* Aha. They've got it stowed in magic. Bring it back. */ + av = (AV*)mg->mg_obj; + /* Stop mg_free decreasing the refernce count. */ + mg->mg_obj = NULL; + /* Stop mg_free even calling the destructor, given that + there's no AV to free up. */ + mg->mg_virtual = 0; + sv_unmagic(tsv, PERL_MAGIC_backref); + } else { + av = newAV(); + AvREAL_off(av); + SvREFCNT_inc(av); + } + *avp = av; + } + } else { + const MAGIC *const mg + = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; + if (mg) + av = (AV*)mg->mg_obj; + else { + av = newAV(); + AvREAL_off(av); + sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); + /* av now has a refcnt of 2, which avoids it getting freed + * before us during global cleanup. The extra ref is removed + * by magic_killbackrefs() when tsv is being freed */ + } } if (AvFILLp(av) >= AvMAX(av)) { av_extend(av, AvFILLp(av)+1); @@ -4374,17 +4403,28 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) STATIC void S_sv_del_backref(pTHX_ SV *tsv, SV *sv) { - AV *av; + AV *av = NULL; SV **svp; I32 i; - MAGIC *mg = NULL; - if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) { + + if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) { + av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv); + } + if (!av) { + const MAGIC *const mg + = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; + if (mg) + av = (AV *)mg->mg_obj; + } + if (!av) { if (PL_in_clean_all) return; - } - if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) Perl_croak(aTHX_ "panic: del_backref"); - av = (AV *)mg->mg_obj; + } + + if (SvIS_FREED(av)) + return; + svp = AvARRAY(av); /* We shouldn't be in here more than once, but for paranoia reasons lets not assume this. */ @@ -4405,6 +4445,47 @@ S_sv_del_backref(pTHX_ SV *tsv, SV *sv) } } +int +Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) +{ + SV **svp = AvARRAY(av); + + PERL_UNUSED_ARG(sv); + + /* Not sure why the av can get freed ahead of its sv, but somehow it does + in ext/B/t/bytecode.t test 15 (involving print <DATA>) */ + if (svp && !SvIS_FREED(av)) { + SV *const *const last = svp + AvFILLp(av); + + while (svp <= last) { + if (*svp) { + SV *const referrer = *svp; + if (SvWEAKREF(referrer)) { + /* XXX Should we check that it hasn't changed? */ + SvRV_set(referrer, 0); + SvOK_off(referrer); + SvWEAKREF_off(referrer); + } else if (SvTYPE(referrer) == SVt_PVGV || + SvTYPE(referrer) == SVt_PVLV) { + /* You lookin' at me? */ + assert(GvSTASH(referrer)); + assert(GvSTASH(referrer) == (HV*)sv); + GvSTASH(referrer) = 0; + } else { + Perl_croak(aTHX_ + "panic: magic_killbackrefs (flags=%"UVxf")", + (UV)SvFLAGS(referrer)); + } + + *svp = Nullsv; + } + svp++; + } + } + SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ + return 0; +} + /* =for apidoc sv_insert @@ -4686,6 +4767,7 @@ Perl_sv_clear(pTHX_ register SV *sv) cv_undef((CV*)sv); goto freescalar; case SVt_PVHV: + Perl_hv_kill_backrefs(aTHX_ (HV*)sv); hv_undef((HV*)sv); break; case SVt_PVAV: @@ -9482,6 +9564,12 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr), param) : 0; + daux->xhv_backreferences = saux->xhv_backreferences + ? (AV*) SvREFCNT_inc( + sv_dup((SV*)saux-> + xhv_backreferences, + param)) + : 0; } } else { |