diff options
| -rw-r--r-- | av.c | 8 | ||||
| -rw-r--r-- | dump.c | 5 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 6 | ||||
| -rw-r--r-- | embedvar.h | 4 | ||||
| -rw-r--r-- | ext/Storable/t/st-dump.pl | 1 | ||||
| -rw-r--r-- | hv.c | 51 | ||||
| -rw-r--r-- | perl.c | 2 | ||||
| -rw-r--r-- | perlapi.h | 4 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | sv.c | 23 | ||||
| -rw-r--r-- | sv.h | 3 | ||||
| -rwxr-xr-x | t/op/tie.t | 31 | ||||
| -rw-r--r-- | thrdvar.h | 4 |
14 files changed, 109 insertions, 35 deletions
@@ -209,9 +209,11 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) } sv = sv_newmortal(); - mg_copy((SV*)av, sv, 0, key); - PL_av_fetch_sv = sv; - return &PL_av_fetch_sv; + sv_upgrade(sv, SVt_PVLV); + mg_copy((SV*)av, sv, 0, key); + LvTYPE(sv) = 't'; + LvTARG(sv) = sv; /* fake (SV**) */ + return &(LvTARG(sv)); } } @@ -1180,8 +1180,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv)); Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv)); Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv))); - /* XXX level+1 ??? */ - do_sv_dump(level, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim); + if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T') + do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, + dumpops, pvlim); break; case SVt_PVAV: Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv))); @@ -1375,6 +1375,7 @@ sd |void |cv_dump |CV *cv|char *title s |CV* |cv_clone2 |CV *proto|CV *outside #endif pd |CV* |find_runcv |U32 *db_seqp +p |void |free_tied_hv_pool @@ -2127,6 +2127,9 @@ #ifdef PERL_CORE #define find_runcv Perl_find_runcv #endif +#ifdef PERL_CORE +#define free_tied_hv_pool Perl_free_tied_hv_pool +#endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat @@ -4590,6 +4593,9 @@ #ifdef PERL_CORE #define find_runcv(a) Perl_find_runcv(aTHX_ a) #endif +#ifdef PERL_CORE +#define free_tied_hv_pool() Perl_free_tied_hv_pool(aTHX) +#endif #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) diff --git a/embedvar.h b/embedvar.h index b0b81b9a79..54777057e8 100644 --- a/embedvar.h +++ b/embedvar.h @@ -40,7 +40,6 @@ #define PL_Sv (vTHX->TSv) #define PL_Xpv (vTHX->TXpv) -#define PL_av_fetch_sv (vTHX->Tav_fetch_sv) #define PL_bodytarget (vTHX->Tbodytarget) #define PL_bostr (vTHX->Tbostr) #define PL_chopset (vTHX->Tchopset) @@ -63,7 +62,6 @@ #define PL_firstgv (vTHX->Tfirstgv) #define PL_formtarget (vTHX->Tformtarget) #define PL_hv_fetch_ent_mh (vTHX->Thv_fetch_ent_mh) -#define PL_hv_fetch_sv (vTHX->Thv_fetch_sv) #define PL_in_eval (vTHX->Tin_eval) #define PL_last_in_gv (vTHX->Tlast_in_gv) #define PL_lastgotoprobe (vTHX->Tlastgotoprobe) @@ -747,7 +745,6 @@ #define PL_TSv PL_Sv #define PL_TXpv PL_Xpv -#define PL_Tav_fetch_sv PL_av_fetch_sv #define PL_Tbodytarget PL_bodytarget #define PL_Tbostr PL_bostr #define PL_Tchopset PL_chopset @@ -770,7 +767,6 @@ #define PL_Tfirstgv PL_firstgv #define PL_Tformtarget PL_formtarget #define PL_Thv_fetch_ent_mh PL_hv_fetch_ent_mh -#define PL_Thv_fetch_sv PL_hv_fetch_sv #define PL_Tin_eval PL_in_eval #define PL_Tlast_in_gv PL_last_in_gv #define PL_Tlastgotoprobe PL_lastgotoprobe diff --git a/ext/Storable/t/st-dump.pl b/ext/Storable/t/st-dump.pl index c56ea0a8fa..152b85a101 100644 --- a/ext/Storable/t/st-dump.pl +++ b/ext/Storable/t/st-dump.pl @@ -39,6 +39,7 @@ use Carp; %dump = ( 'SCALAR' => 'dump_scalar', + 'LVALUE' => 'dump_scalar', 'ARRAY' => 'dump_array', 'HASH' => 'dump_hash', 'REF' => 'dump_ref', @@ -90,6 +90,22 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) return hek; } +/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent + * for tied hashes */ + +void +Perl_free_tied_hv_pool(pTHX) +{ + HE *ohe; + HE *he = PL_hv_fetch_ent_mh; + while (he) { + Safefree(HeKEY_hek(he)); + ohe = he; + he = HeNEXT(he); + del_HE(ohe); + } +} + #if defined(USE_ITHREADS) HE * Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) @@ -108,8 +124,12 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) ptr_table_store(PL_ptr_table, e, ret); HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); - if (HeKLEN(e) == HEf_SVKEY) + if (HeKLEN(e) == HEf_SVKEY) { + char *k; + New(54, k, HEK_BASESIZE + sizeof(SV*), char); + HeKEY_hek(ret) = (HEK*)k; HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param)); + } else if (shared) HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), HeKFLAGS(e)); @@ -209,11 +229,13 @@ S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags) */ if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { sv = sv_newmortal(); + sv_upgrade(sv, SVt_PVLV); mg_copy((SV*)hv, sv, key, klen); if (flags & HVhek_FREEKEY) Safefree(key); - PL_hv_fetch_sv = sv; - return &PL_hv_fetch_sv; + LvTYPE(sv) = 't'; + LvTARG(sv) = sv; /* fake (SV**) */ + return &(LvTARG(sv)); } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { @@ -357,17 +379,26 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { sv = sv_newmortal(); - keysv = sv_2mortal(newSVsv(keysv)); + keysv = newSVsv(keysv); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); - if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) { + /* grab a fake HE/HEK pair from the pool or make a new one */ + entry = PL_hv_fetch_ent_mh; + if (entry) + PL_hv_fetch_ent_mh = HeNEXT(entry); + else { char *k; + entry = new_HE(); New(54, k, HEK_BASESIZE + sizeof(SV*), char); - HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k; + HeKEY_hek(entry) = (HEK*)k; } - HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv); - HeVAL(&PL_hv_fetch_ent_mh) = sv; - return &PL_hv_fetch_ent_mh; - } + HeNEXT(entry) = Nullhe; + HeSVKEY_set(entry, keysv); + HeVAL(entry) = sv; + sv_upgrade(sv, SVt_PVLV); + LvTYPE(sv) = 'T'; + LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */ + return entry; + } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv, PERL_MAGIC_env)) { U32 i; @@ -789,7 +789,7 @@ perl_destruct(pTHXx) if (PL_reg_curpm) Safefree(PL_reg_curpm); Safefree(PL_reg_poscache); - Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); + free_tied_hv_pool(); Safefree(PL_op_mask); Safefree(PL_psig_ptr); Safefree(PL_psig_name); @@ -664,8 +664,6 @@ END_EXTERN_C #define PL_Sv (*Perl_TSv_ptr(aTHX)) #undef PL_Xpv #define PL_Xpv (*Perl_TXpv_ptr(aTHX)) -#undef PL_av_fetch_sv -#define PL_av_fetch_sv (*Perl_Tav_fetch_sv_ptr(aTHX)) #undef PL_bodytarget #define PL_bodytarget (*Perl_Tbodytarget_ptr(aTHX)) #undef PL_bostr @@ -710,8 +708,6 @@ END_EXTERN_C #define PL_formtarget (*Perl_Tformtarget_ptr(aTHX)) #undef PL_hv_fetch_ent_mh #define PL_hv_fetch_ent_mh (*Perl_Thv_fetch_ent_mh_ptr(aTHX)) -#undef PL_hv_fetch_sv -#define PL_hv_fetch_sv (*Perl_Thv_fetch_sv_ptr(aTHX)) #undef PL_in_eval #define PL_in_eval (*Perl_Tin_eval_ptr(aTHX)) #undef PL_last_in_gv @@ -1398,6 +1398,7 @@ STATIC void S_cv_dump(pTHX_ CV *cv, char *title); STATIC CV* S_cv_clone2(pTHX_ CV *proto, CV *outside); #endif PERL_CALLCONV CV* Perl_find_runcv(pTHX_ U32 *db_seqp); +PERL_CALLCONV void Perl_free_tied_hv_pool(pTHX); @@ -3069,7 +3069,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) s = "REF"; else s = "SCALAR"; break; - case SVt_PVLV: s = "LVALUE"; break; + case SVt_PVLV: s = SvROK(sv) ? "REF":"LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; case SVt_PVCV: s = "CODE"; break; @@ -5393,7 +5393,13 @@ Perl_sv_clear(pTHX_ register SV *sv) av_undef((AV*)sv); break; case SVt_PVLV: - SvREFCNT_dec(LvTARG(sv)); + if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ + SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); + HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; + PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); + } + else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ + SvREFCNT_dec(LvTARG(sv)); goto freescalar; case SVt_PVGV: gp_free((GV*)sv); @@ -7784,7 +7790,7 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) return "REF"; else return "SCALAR"; - case SVt_PVLV: return "LVALUE"; + case SVt_PVLV: return SvROK(sv) ? "REF" : "LVALUE"; case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; @@ -10004,7 +10010,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) Perl_rvpv_dup(aTHX_ dstr, sstr, param); LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ LvTARGLEN(dstr) = LvTARGLEN(sstr); - LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); + if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */ + LvTARG(dstr) = dstr; + else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */ + LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param); + else + LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); LvTYPE(dstr) = LvTYPE(sstr); break; case SVt_PVGV: @@ -11332,9 +11343,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_protect = proto_perl->Tprotect; #endif PL_errors = sv_dup_inc(proto_perl->Terrors, param); - PL_av_fetch_sv = Nullsv; - PL_hv_fetch_sv = Nullsv; - Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */ + PL_hv_fetch_ent_mh = Nullhe; PL_modcount = proto_perl->Tmodcount; PL_lastgotoprobe = Nullop; PL_dumpindent = proto_perl->Tdumpindent; @@ -274,7 +274,8 @@ struct xpvlv { STRLEN xlv_targoff; STRLEN xlv_targlen; SV* xlv_targ; - char xlv_type; + char xlv_type; /* k=keys .=pos x=substr v=vec /=join/re + * y=alem/helem/iter t=tie T=tied HE */ }; struct xpvgv { diff --git a/t/op/tie.t b/t/op/tie.t index 49c189e66f..d643b78282 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -295,3 +295,34 @@ tie $a, 'main'; print $a; EXPECT Tied variable freed while still in use at - line 6. +######## + +# [20020716.007] - nested FETCHES + +sub F1::TIEARRAY { bless [], 'F1' } +sub F1::FETCH { 1 } +my @f1; +tie @f1, 'F1'; + +sub F2::TIEARRAY { bless [2], 'F2' } +sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self } +my @f2; +tie @f2, 'F2'; + +print $f2[4][0],"\n"; + +sub F3::TIEHASH { bless [], 'F3' } +sub F3::FETCH { 1 } +my %f3; +tie %f3, 'F3'; + +sub F4::TIEHASH { bless [3], 'F4' } +sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self } +my %f4; +tie %f4, 'F4'; + +print $f4{'foo'}[0],"\n"; + +EXPECT +2 +3 @@ -140,9 +140,7 @@ PERLVARI(Tprotect, protect_proc_t, MEMBER_TO_FPTR(Perl_default_protect)) PERLVARI(Terrors, SV *, Nullsv) /* outstanding queued errors */ /* statics "owned" by various functions */ -PERLVAR(Tav_fetch_sv, SV *) /* owned by av_fetch() */ -PERLVAR(Thv_fetch_sv, SV *) /* owned by hv_fetch() */ -PERLVAR(Thv_fetch_ent_mh, HE) /* owned by hv_fetch_ent() */ +PERLVAR(Thv_fetch_ent_mh, HE*) /* owned by hv_fetch_ent() */ PERLVAR(Tmodcount, I32) /* how much mod()ification in assignment? */ |