allow recursive FETCHes

Message-ID: <20030407100041.A1617@fdgroup.com>

p4raw-id: //depot/perl@19268

diff --git a/av.c b/av.c
index 8fb22d3..d37ba01 100644 (file)
--- a/av.c
+++ b/av.c
@@ -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));
         }
     }
 

diff --git a/dump.c b/dump.c
index 6c526df..244d064 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -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)));

diff --git a/embed.fnc b/embed.fnc
index 8880585..8e61254 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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
 
 
 

diff --git a/embed.h b/embed.h
index fc12d71..325217b 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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 b0b81b9..5477705 100644 (file)
--- 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 c56ea0a..152b85a 100644 (file)
--- 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',

diff --git a/hv.c b/hv.c
index 217244d..438042b 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -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;

diff --git a/perl.c b/perl.c
index e677bd5..77cd0c9 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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);

diff --git a/perlapi.h b/perlapi.h
index 945ce26..e350586 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -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

diff --git a/proto.h b/proto.h
index c12840d..b8fe978 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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);
 
 
 

diff --git a/sv.c b/sv.c
index 1de42fb..5280c08 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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;

diff --git a/sv.h b/sv.h
index 9a0cef7..f63d058 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -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 49c189e..d643b78 100755 (executable)
--- 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

diff --git a/thrdvar.h b/thrdvar.h
index 6958f55..19f233e 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -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? */